From 4d19a274241b0310575c515b5099697e96a67206 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 21 Jun 2015 14:38:20 +0200 Subject: [PATCH] cosmetic: untabify MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Daniel Kochmański --- src/bare.lsp.in | 72 +- src/c/all_symbols.d | 422 +- src/c/alloc.d | 1204 +++--- src/c/alloc_2.d | 1034 ++--- src/c/apply.d | 1010 ++--- src/c/arch/apply_x86.d | 138 +- src/c/arch/ffi_ppc32.d | 244 +- src/c/arch/ffi_x86.d | 370 +- src/c/arch/ffi_x86_64.d | 476 +-- src/c/array.d | 1452 +++---- src/c/assignment.d | 228 +- src/c/backq.d | 388 +- src/c/big.d | 170 +- src/c/big_ll.d | 46 +- src/c/cfun.d | 198 +- src/c/char_ctype.d | 72 +- src/c/character.d | 526 +-- src/c/cinit.d | 88 +- src/c/clos/accessor.d | 250 +- src/c/clos/cache.d | 288 +- src/c/cmpaux.d | 242 +- src/c/compiler.d | 3158 +++++++------- src/c/disassembler.d | 1028 ++--- src/c/dpp.c | 1148 ++--- src/c/earith.d | 528 +-- src/c/ecl_features.h | 50 +- src/c/error.d | 270 +- src/c/eval.d | 328 +- src/c/ffi.d | 792 ++-- src/c/ffi/backtrace.d | 64 +- src/c/ffi/cdata.d | 2 +- src/c/ffi/libraries.d | 394 +- src/c/file.d | 6344 ++++++++++++++-------------- src/c/format.d | 3424 +++++++-------- src/c/gbc-new.d | 1112 ++--- src/c/gbc.d | 1336 +++--- src/c/gfun.d | 296 +- src/c/hash.d | 1364 +++--- src/c/instance.d | 490 +-- src/c/interpreter.d | 1882 ++++----- src/c/iso_latin_names.h | 22 +- src/c/list.d | 1234 +++--- src/c/load.d | 378 +- src/c/macros.d | 200 +- src/c/main.d | 902 ++-- src/c/mapfun.d | 232 +- src/c/multival.d | 48 +- src/c/newhash.h | 268 +- src/c/num_arith.d | 114 +- src/c/num_co.d | 598 +-- src/c/num_log.d | 762 ++-- src/c/num_pred.d | 46 +- src/c/num_rand.d | 204 +- src/c/number.d | 822 ++-- src/c/numbers/abs.d | 6 +- src/c/numbers/atan.d | 144 +- src/c/numbers/ceiling.d | 364 +- src/c/numbers/cos.d | 2 +- src/c/numbers/divide.d | 274 +- src/c/numbers/expt.d | 82 +- src/c/numbers/float_fix_compare.d | 76 +- src/c/numbers/floor.d | 398 +- src/c/numbers/log.d | 92 +- src/c/numbers/minmax.d | 40 +- src/c/numbers/minus.d | 284 +- src/c/numbers/minusp.d | 4 +- src/c/numbers/number_compare.d | 296 +- src/c/numbers/number_equalp.d | 274 +- src/c/numbers/one_minus.d | 6 +- src/c/numbers/one_plus.d | 4 +- src/c/numbers/plus.d | 280 +- src/c/numbers/plusp.d | 4 +- src/c/numbers/round.d | 200 +- src/c/numbers/sin.d | 2 +- src/c/numbers/tanh.d | 4 +- src/c/numbers/times.d | 302 +- src/c/numbers/truncate.d | 94 +- src/c/numbers/zerop.d | 4 +- src/c/package.d | 814 ++-- src/c/pathname.d | 2346 +++++----- src/c/predicate.d | 494 +-- src/c/print.d | 402 +- src/c/printer/integer_to_string.d | 10 +- src/c/printer/print_unreadable.d | 70 +- src/c/printer/write_array.d | 264 +- src/c/printer/write_code.d | 14 +- src/c/printer/write_list.d | 16 +- src/c/printer/write_object.d | 190 +- src/c/printer/write_sse.d | 64 +- src/c/printer/write_symbol.d | 310 +- src/c/printer/write_ugly.d | 138 +- src/c/read.d | 3054 ++++++------- src/c/reader/parse_integer.d | 138 +- src/c/reader/parse_number.d | 28 +- src/c/reference.d | 208 +- src/c/sequence.d | 288 +- src/c/serialize.d | 140 +- src/c/sse2.d | 158 +- src/c/stacks.d | 536 +-- src/c/string.d | 1040 ++--- src/c/structure.d | 154 +- src/c/symbol.d | 448 +- src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/c/tcp.d | 194 +- src/c/threads/atomic.d | 26 +- src/c/threads/barrier.d | 192 +- src/c/threads/condition_variable.d | 74 +- src/c/threads/mailbox.d | 126 +- src/c/threads/mutex.d | 170 +- src/c/threads/process.d | 812 ++-- src/c/threads/queue.d | 512 +-- src/c/threads/rwlock.d | 48 +- src/c/threads/semaphore.d | 108 +- src/c/time.d | 234 +- src/c/typespec.d | 460 +- src/c/unicode/ucd_names_char.c | 2 +- src/c/unify.d | 196 +- src/c/unixfsys.d | 1394 +++--- src/c/unixint.d | 1410 +++---- src/c/unixsys.d | 660 +-- src/c/vector_push.d | 92 +- src/clos/boot.lsp | 106 +- src/clos/builtin.lsp | 22 +- src/clos/change.lsp | 164 +- src/clos/cmpinit.lsp | 6 +- src/clos/combin.lsp | 320 +- src/clos/conditions.lsp | 666 +-- src/clos/cpl.lsp | 200 +- src/clos/defclass.lsp | 116 +- src/clos/fixup.lsp | 122 +- src/clos/generic.lsp | 202 +- src/clos/hierarchy.lsp | 186 +- src/clos/inspect.lsp | 454 +- src/clos/kernel.lsp | 412 +- src/clos/method.lsp | 420 +- src/clos/package.lsp | 2 +- src/clos/print.lsp | 220 +- src/clos/slot.lsp | 120 +- src/clos/slotvalue.lsp | 18 +- src/clos/standard.lsp | 516 +-- src/clos/std-accessors.lsp | 186 +- src/clos/std-slot-value.lsp | 210 +- src/clos/stdmethod.lsp | 28 +- src/clos/streams.lsp | 42 +- src/clos/walk.lsp | 980 ++--- src/clx/attributes.lisp | 298 +- src/clx/big-requests.lisp | 6 +- src/clx/buffer.lisp | 1206 +++--- src/clx/bufmac.lisp | 140 +- src/clx/build-clx.lisp | 2 +- src/clx/clx.lisp | 456 +- src/clx/cmudep.lisp | 2 +- src/clx/debug/debug.lisp | 42 +- src/clx/debug/describe.lisp | 1644 +++---- src/clx/debug/event-test.lisp | 328 +- src/clx/debug/keytrans.lisp | 314 +- src/clx/debug/trace.lisp | 466 +- src/clx/debug/util.lisp | 122 +- src/clx/defsystem.lisp | 270 +- src/clx/demo/bezier.lisp | 12 +- src/clx/demo/beziertest.lisp | 92 +- src/clx/demo/clclock.lisp | 48 +- src/clx/demo/clipboard.lisp | 84 +- src/clx/demo/clx-demos.lisp | 886 ++-- src/clx/demo/hello.lisp | 110 +- src/clx/demo/mandel.lisp | 584 +-- src/clx/demo/menu.lisp | 432 +- src/clx/demo/zoid.lisp | 18 +- src/clx/dep-allegro.lisp | 2000 ++++----- src/clx/dep-openmcl.lisp | 590 +-- src/clx/depdefs.lisp | 336 +- src/clx/dependent.lisp | 3222 +++++++------- src/clx/display.lisp | 534 +-- src/clx/exclcmac.lisp | 128 +- src/clx/excldefsys.lisp | 104 +- src/clx/excldep.lisp | 222 +- src/clx/fonts.lisp | 410 +- src/clx/gcontext.lisp | 1048 ++--- src/clx/generalock.lisp | 84 +- src/clx/graphics.lisp | 570 +-- src/clx/image.lisp | 3828 ++++++++--------- src/clx/input.lisp | 1596 +++---- src/clx/keysyms.lisp | 238 +- src/clx/macros.lisp | 800 ++-- src/clx/manager.lisp | 680 +-- src/clx/provide.lisp | 44 +- src/clx/requests.lisp | 1212 +++--- src/clx/resource.lisp | 630 +-- src/clx/screensaver.lisp | 4 +- src/clx/sockcl.lisp | 82 +- src/clx/socket.c | 112 +- src/clx/test/image.lisp | 180 +- src/clx/test/trapezoid.lisp | 88 +- src/clx/text.lisp | 1410 +++---- src/clx/translate.lisp | 434 +- src/clx/xinerama.lisp | 16 +- src/clx/xrender.lisp | 136 +- src/clx/xvidmode.lisp | 420 +- src/cmp/cmparray.lsp | 82 +- src/cmp/cmpbind.lsp | 78 +- src/cmp/cmpblock.lsp | 116 +- src/cmp/cmpc-inliner.lsp | 10 +- src/cmp/cmpc-machine.lsp | 34 +- src/cmp/cmpc-wt.lsp | 68 +- src/cmp/cmpcall.lsp | 164 +- src/cmp/cmpcatch.lsp | 44 +- src/cmp/cmpcbk.lsp | 98 +- src/cmp/cmpclos.lsp | 76 +- src/cmp/cmpct.lsp | 64 +- src/cmp/cmpenv-api.lsp | 146 +- src/cmp/cmpenv-declare.lsp | 16 +- src/cmp/cmpenv-fun.lsp | 108 +- src/cmp/cmpenv-proclaim.lsp | 86 +- src/cmp/cmpeval.lsp | 248 +- src/cmp/cmpexit.lsp | 260 +- src/cmp/cmpffi.lsp | 522 +-- src/cmp/cmpflet.lsp | 224 +- src/cmp/cmpform.lsp | 78 +- src/cmp/cmpfun.lsp | 94 +- src/cmp/cmpglobals.lsp | 96 +- src/cmp/cmpif.lsp | 120 +- src/cmp/cmpinline.lsp | 8 +- src/cmp/cmplam.lsp | 552 +-- src/cmp/cmplet.lsp | 168 +- src/cmp/cmploc.lsp | 180 +- src/cmp/cmpmac.lsp | 16 +- src/cmp/cmpmain.lsp | 544 +-- src/cmp/cmpmap.lsp | 52 +- src/cmp/cmpmulti.lsp | 170 +- src/cmp/cmpname.lsp | 118 +- src/cmp/cmpnum.lsp | 112 +- src/cmp/cmpopt-bits.lsp | 172 +- src/cmp/cmpopt-clos.lsp | 90 +- src/cmp/cmpopt-cons.lsp | 56 +- src/cmp/cmpopt-constant.lsp | 8 +- src/cmp/cmpopt-type.lsp | 28 +- src/cmp/cmpopt.lsp | 444 +- src/cmp/cmpos-run.lsp | 10 +- src/cmp/cmppackage.lsp | 50 +- src/cmp/cmppolicy.lsp | 2 +- src/cmp/cmpprop.lsp | 108 +- src/cmp/cmpspecial.lsp | 148 +- src/cmp/cmpstack.lsp | 42 +- src/cmp/cmpstructures.lsp | 124 +- src/cmp/cmptables.lsp | 88 +- src/cmp/cmptag.lsp | 224 +- src/cmp/cmptop.lsp | 490 +-- src/cmp/cmptype-arith.lsp | 228 +- src/cmp/cmptype-assert.lsp | 160 +- src/cmp/cmptype.lsp | 52 +- src/cmp/cmptypes.lsp | 246 +- src/cmp/cmputil.lsp | 102 +- src/cmp/cmpvar.lsp | 220 +- src/cmp/cmpwt.lsp | 238 +- src/cmp/defsys.lsp.in | 64 +- src/cmp/proclamations.lsp | 4 +- src/cmp/sysfun.lsp | 32 +- src/compile.lsp.in | 128 +- src/doc/help.lsp | 512 +-- src/h/bytecodes.h | 44 +- src/h/cache.h | 14 +- src/h/config.h.in | 188 +- src/h/cons.h | 6 +- src/h/cs.h | 152 +- src/h/ecl-cmp.h | 14 +- src/h/ecl-inl.h | 24 +- src/h/ecl.h | 12 +- src/h/external.h | 366 +- src/h/internal.h | 104 +- src/h/legacy.h | 98 +- src/h/number.h | 66 +- src/h/object.h | 1224 +++--- src/h/page.h | 94 +- src/h/stacks.h | 286 +- src/h/unify.h | 28 +- src/lsp/arraylib.lsp | 164 +- src/lsp/assert.lsp | 124 +- src/lsp/autoload.lsp | 268 +- src/lsp/cmdline.lsp | 110 +- src/lsp/cmuutil.lsp | 74 +- src/lsp/config.lsp.in | 40 +- src/lsp/defmacro.lsp | 420 +- src/lsp/defpackage.lsp | 294 +- src/lsp/defstruct.lsp | 368 +- src/lsp/defsys.lsp.in | 68 +- src/lsp/describe.lsp | 304 +- src/lsp/evalmacros.lsp | 110 +- src/lsp/export.lsp | 216 +- src/lsp/ffi.lsp | 434 +- src/lsp/format.lsp | 2848 ++++++------- src/lsp/helpfile.lsp | 24 +- src/lsp/init.lsp | 6 +- src/lsp/iolib.lsp | 146 +- src/lsp/listlib.lsp | 22 +- src/lsp/loop.lsp | 1534 +++---- src/lsp/loop2.lsp | 1696 ++++---- src/lsp/mislib.lsp | 170 +- src/lsp/module.lsp | 40 +- src/lsp/mp.lsp | 16 +- src/lsp/numlib.lsp | 134 +- src/lsp/packlib.lsp | 258 +- src/lsp/pprint.lsp | 1468 +++---- src/lsp/predlib.lsp | 1024 ++--- src/lsp/seq.lsp | 140 +- src/lsp/seqlib.lsp | 316 +- src/lsp/seqmacros.lsp | 110 +- src/lsp/setf.lsp | 386 +- src/lsp/top.lsp | 1206 +++--- src/lsp/trace.lsp | 238 +- src/lsp/util.lsp | 14 +- src/new-cmp/cmpblock.lsp | 22 +- src/new-cmp/cmpc-bind.lsp | 50 +- src/new-cmp/cmpc-cbk.lsp | 98 +- src/new-cmp/cmpc-data.lsp | 42 +- src/new-cmp/cmpc-ffi.lsp | 362 +- src/new-cmp/cmpc-loc.lsp | 130 +- src/new-cmp/cmpc-ops.lsp | 68 +- src/new-cmp/cmpc-pass.lsp | 8 +- src/new-cmp/cmpc-set.lsp | 2 +- src/new-cmp/cmpc-top.lsp | 20 +- src/new-cmp/cmpcall.lsp | 74 +- src/new-cmp/cmpcatch.lsp | 28 +- src/new-cmp/cmpcffi.lsp | 64 +- src/new-cmp/cmpclos.lsp | 74 +- src/new-cmp/cmpdata.lsp | 78 +- src/new-cmp/cmpeval.lsp | 104 +- src/new-cmp/cmpflet.lsp | 136 +- src/new-cmp/cmpform.lsp | 40 +- src/new-cmp/cmpfun.lsp | 70 +- src/new-cmp/cmplam.lsp | 198 +- src/new-cmp/cmplet.lsp | 6 +- src/new-cmp/cmploc.lsp | 118 +- src/new-cmp/cmpmain.lsp | 576 +-- src/new-cmp/cmpmap.lsp | 52 +- src/new-cmp/cmpmulti.lsp | 32 +- src/new-cmp/cmpnum.lsp | 4 +- src/new-cmp/cmppackage.lsp | 64 +- src/new-cmp/cmppass.lsp | 84 +- src/new-cmp/cmpprop.lsp | 82 +- src/new-cmp/cmpspecial.lsp | 24 +- src/new-cmp/cmpstack.lsp | 10 +- src/new-cmp/cmpstructures.lsp | 106 +- src/new-cmp/cmptag.lsp | 80 +- src/new-cmp/cmptop.lsp | 122 +- src/new-cmp/cmptranslate.lsp | 4 +- src/new-cmp/cmpvar.lsp | 84 +- src/new-cmp/defsys.lsp.in | 64 +- src/tests/bugs/cl-001.lsp | 304 +- src/tests/bugs/cmp-001.lsp | 398 +- src/tests/bugs/eformat-001.lsp | 132 +- src/tests/bugs/eformat-002.lsp | 158 +- src/tests/bugs/emb-001.lsp | 28 +- src/tests/bugs/ffi-001.lsp | 28 +- src/tests/bugs/int-001.lsp | 8 +- src/tests/bugs/mailbox-001.lsp | 138 +- src/tests/bugs/mop-001.lsp | 230 +- src/tests/bugs/mop-dependents.lsp | 204 +- src/tests/bugs/mop-dispatch.lsp | 170 +- src/tests/bugs/mp-001.lsp | 30 +- src/tests/bugs/mp-tools.lsp | 16 +- src/tests/bugs/mutex-001.lsp | 128 +- src/tests/bugs/num-001.lsp | 2 +- src/tests/bugs/sem-001.lsp | 268 +- src/tests/bugs/tools.lsp | 40 +- src/tests/config.lsp.in | 232 +- src/util/cut.c | 18 +- src/util/defsys.lsp | 4 +- src/util/gen-code.lisp | 86 +- src/util/system.lsp | 162 +- 370 files changed, 63383 insertions(+), 63383 deletions(-) diff --git a/src/bare.lsp.in b/src/bare.lsp.in index dd8e77f03..6b69398f7 100644 --- a/src/bare.lsp.in +++ b/src/bare.lsp.in @@ -49,7 +49,7 @@ ;;; ") (if (or (member "ECL-MIN" *features* :test #'string-equal) - (member "CROSS" *features* :test #'string-equal)) + (member "CROSS" *features* :test #'string-equal)) (load "lsp/load.lsp" :verbose nil)) (defun si::process-command-args () ) @@ -101,14 +101,14 @@ (defun compile-if-old (destdir sources &rest options) (ensure-directories-exist destdir :mode #o0777) (mapcar #'(lambda (source) - (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) - (unless (and (probe-file object) - (>= (file-write-date object) (file-write-date source))) - (format t "~&(compile-file ~S :output-file ~S~{ ~S~})~%" - source object options) - (apply #'compile-file source :output-file object options)) - object)) - sources)) + (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) + (unless (and (probe-file object) + (>= (file-write-date object) (file-write-date source))) + (format t "~&(compile-file ~S :output-file ~S~{ ~S~})~%" + source object options) + (apply #'compile-file source :output-file object options)) + object)) + sources)) (defvar *module-symbols* nil) (defvar *module-files* nil) @@ -129,21 +129,21 @@ (defun build-fake-asdf (name static-library compiled-filename &key depends-on) (let ((path (make-pathname :name name :type "asd")) - (compiled (make-pathname :host "SYS" - :name (pathname-name compiled-filename) - :type (pathname-type compiled-filename))) - (library (make-pathname :host "SYS" - :name (pathname-name static-library) - :type (pathname-type static-library)))) + (compiled (make-pathname :host "SYS" + :name (pathname-name compiled-filename) + :type (pathname-type compiled-filename))) + (library (make-pathname :host "SYS" + :name (pathname-name static-library) + :type (pathname-type static-library)))) (with-open-file (*standard-output* path :direction :output :if-exists :supersede :if-does-not-exist :create) (format t " (defsystem ~S :class asdf::prebuilt-system - :lib ~S - :depends-on ~S - :components ((:compiled-file ~S :pathname ~S)))" - name library depends-on (string name) compiled)) + :lib ~S + :depends-on ~S + :components ((:compiled-file ~S :pathname ~S)))" + name library depends-on (string name) compiled)) path)) (defun build-module (name sources &key additional-files depends-on @@ -155,8 +155,8 @@ (setf *module-files* (append additional-files *module-files*))) (let* ((objects (compile-if-old dir sources :system-p t :c-file t :data-file t :h-file t)) - (compiled-file-name (string name)) - (static-library (c::build-static-library name :lisp-files objects))) + (compiled-file-name (string name)) + (static-library (c::build-static-library name :lisp-files objects))) (push static-library *module-files*) (when builtin (push (intern name) *module-symbols*)) @@ -164,11 +164,11 @@ (push (build-fake-module name sources) *module-files*) #+:wants-dlopen (push (setf compiled-file-name (c::build-fasl name :lisp-files objects)) - *module-files*) + *module-files*) (push (if (equalp name "asdf") - (build-fake-asdf "prebuilt-asdf" static-library compiled-file-name :depends-on '("cmp")) - (build-fake-asdf name static-library compiled-file-name :depends-on depends-on)) - *module-files*) + (build-fake-asdf "prebuilt-asdf" static-library compiled-file-name :depends-on '("cmp")) + (build-fake-asdf name static-library compiled-file-name :depends-on depends-on)) + *module-files*) ))) ;;; @@ -179,18 +179,18 @@ (when commit-id (let ((last nil)) (with-open-file (file commit-id :direction :input :element-type :default - :external-format :default) - (loop for l = (read-line file nil nil nil) - while l - do (setf last l))) + :external-format :default) + (loop for l = (read-line file nil nil nil) + while l + do (setf last l))) (when last - (handler-case - (let* ((start (position #\Space last))) - (when start - (let ((end (position #\Space last :start (incf start)))) - (when end - (setq si::+commit-id+ (subseq last start end)))))) - (serious-condition ())))))) + (handler-case + (let* ((start (position #\Space last))) + (when start + (let ((end (position #\Space last :start (incf start)))) + (when end + (setq si::+commit-id+ (subseq last start end)))))) + (serious-condition ())))))) ;;; ;;; * Go back to build directory to start compiling ;;; diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index b1a31b052..d339a07ea 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -18,26 +18,26 @@ #define FORM_SYMBOL 3 #define PRIVATE 256 -#define CL_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL -#define CL_SPECIAL CL_PACKAGE | SPECIAL_SYMBOL -#define CL_CONSTANT CL_PACKAGE | CONSTANT_SYMBOL -#define CL_FORM CL_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL -#define SI_ORDINARY SI_PACKAGE | ORDINARY_SYMBOL -#define SI_SPECIAL SI_PACKAGE | SPECIAL_SYMBOL -#define SI_CONSTANT SI_PACKAGE | CONSTANT_SYMBOL -#define EXT_ORDINARY EXT_PACKAGE | ORDINARY_SYMBOL -#define EXT_SPECIAL EXT_PACKAGE | SPECIAL_SYMBOL -#define EXT_CONSTANT EXT_PACKAGE | CONSTANT_SYMBOL -#define EXT_FORM EXT_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL -#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL -#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL -#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL -#define CLOS_ORDINARY CLOS_PACKAGE | ORDINARY_SYMBOL -#define CLOS_SPECIAL CLOS_PACKAGE | SPECIAL_SYMBOL -#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL -#define GRAY_ORDINARY GRAY_PACKAGE | ORDINARY_SYMBOL -#define FFI_ORDINARY FFI_PACKAGE | ORDINARY_SYMBOL -#define FFI_CONSTANT FFI_PACKAGE | CONSTANT_SYMBOL +#define CL_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL +#define CL_SPECIAL CL_PACKAGE | SPECIAL_SYMBOL +#define CL_CONSTANT CL_PACKAGE | CONSTANT_SYMBOL +#define CL_FORM CL_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL +#define SI_ORDINARY SI_PACKAGE | ORDINARY_SYMBOL +#define SI_SPECIAL SI_PACKAGE | SPECIAL_SYMBOL +#define SI_CONSTANT SI_PACKAGE | CONSTANT_SYMBOL +#define EXT_ORDINARY EXT_PACKAGE | ORDINARY_SYMBOL +#define EXT_SPECIAL EXT_PACKAGE | SPECIAL_SYMBOL +#define EXT_CONSTANT EXT_PACKAGE | CONSTANT_SYMBOL +#define EXT_FORM EXT_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL +#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL +#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL +#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL +#define CLOS_ORDINARY CLOS_PACKAGE | ORDINARY_SYMBOL +#define CLOS_SPECIAL CLOS_PACKAGE | SPECIAL_SYMBOL +#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL +#define GRAY_ORDINARY GRAY_PACKAGE | ORDINARY_SYMBOL +#define FFI_ORDINARY FFI_PACKAGE | ORDINARY_SYMBOL +#define FFI_CONSTANT FFI_PACKAGE | CONSTANT_SYMBOL #include "symbols_list.h" @@ -46,219 +46,219 @@ cl_index cl_num_symbols_in_core = 0; static unsigned char * mangle_name(cl_object output, unsigned char *source, int l) { - unsigned char c; + unsigned char c; - while (l--) { - c = *(source++); - if (ecl_alphanumericp(c)) { - c = ecl_char_downcase(c); - } else if (c == '-' || c == '_') { - c = '_'; - } else if (c == '&') { - c = 'A'; - } else if (c == '*') { - c = 'X'; - } else if (c == '+') { - c = 'P'; - } else if (c == '<') { - c = 'L'; - } else if (c == '>') { - c = 'G'; - } else if (c == '=') { - c = 'E'; - } else if (c == '/') { - c = 'N'; - } else if (c == ':') { - c = 'X'; - } else { - return NULL; - } - output->base_string.self[output->base_string.fillp++] = c; - } - return &output->base_string.self[output->base_string.fillp]; + while (l--) { + c = *(source++); + if (ecl_alphanumericp(c)) { + c = ecl_char_downcase(c); + } else if (c == '-' || c == '_') { + c = '_'; + } else if (c == '&') { + c = 'A'; + } else if (c == '*') { + c = 'X'; + } else if (c == '+') { + c = 'P'; + } else if (c == '<') { + c = 'L'; + } else if (c == '>') { + c = 'G'; + } else if (c == '=') { + c = 'E'; + } else if (c == '/') { + c = 'N'; + } else if (c == ':') { + c = 'X'; + } else { + return NULL; + } + output->base_string.self[output->base_string.fillp++] = c; + } + return &output->base_string.self[output->base_string.fillp]; } @(defun si::mangle-name (symbol &optional as_function) - cl_index l; - unsigned char c, *source, *dest; - cl_object output; - cl_object package; - cl_object found = ECL_NIL; - cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT); - cl_object minarg = ecl_make_fixnum(0); - bool is_symbol; - cl_object name; + cl_index l; + unsigned char c, *source, *dest; + cl_object output; + cl_object package; + cl_object found = ECL_NIL; + cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT); + cl_object minarg = ecl_make_fixnum(0); + bool is_symbol; + cl_object name; @ - name = ecl_symbol_name(symbol); - is_symbol = Null(as_function); - if (is_symbol) { - cl_fixnum p; - if (symbol == ECL_NIL) - @(return ECL_T make_constant_base_string("ECL_NIL")) - else if (symbol == ECL_T) - @(return ECL_T make_constant_base_string("ECL_T")) - p = (cl_symbol_initializer*)symbol - cl_symbols; - if (p >= 0 && p <= cl_num_symbols_in_core) { - found = ECL_T; - output = cl_format(4, ECL_NIL, - make_constant_base_string("ECL_SYM(~S,~D)"), - name, ecl_make_fixnum(p)); - @(return found output maxarg) - } - } else if (!Null(symbol)) { - cl_object fun = symbol->symbol.gfdef; - cl_type t = (fun == OBJNULL)? t_other : type_of(fun); - if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { - for (l = 0; l <= cl_num_symbols_in_core; l++) { - cl_object s = (cl_object)(cl_symbols + l); - if (fun == ECL_SYM_FUN(s)) { - symbol = s; - found = ECL_T; - if (fun->cfun.narg >= 0) { - minarg = - maxarg = ecl_make_fixnum(fun->cfun.narg); - } - break; - } - } - } - } - package = ecl_symbol_package(symbol); - if (Null(package)) - ; - else if (package == cl_core.lisp_package) - package = make_constant_base_string("cl"); - else if (package == cl_core.system_package) - package = make_constant_base_string("si"); - else if (package == cl_core.ext_package) - package = make_constant_base_string("si"); - else if (package == cl_core.keyword_package) - package = ECL_NIL; - else - package = package->pack.name; - symbol = ecl_symbol_name(symbol); - l = symbol->base_string.fillp; - source = symbol->base_string.self; - output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1); - if (is_symbol && source[0] == '*') { - if (l > 2 && source[l-1] == '*') l--; - c = 'V'; - l--; - source++; - } else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') { - c = 'C'; - l-= 2; - source++; - } else if (!is_symbol) { - c = '_'; - } else if (package == cl_core.keyword_package) { - c = 'K'; - } else { - c = 'S'; - } - output->base_string.fillp = 0; - if (!Null(package)) - if (!mangle_name(output, package->base_string.self, package->base_string.fillp)) - @(return ECL_NIL ECL_NIL maxarg) - output->base_string.self[output->base_string.fillp++] = c; - if (!(dest = mangle_name(output, source, l))) - @(return ECL_NIL ECL_NIL maxarg) - if (dest[-1] == '_') - dest[-1] = 'M'; - *(dest++) = '\0'; - @(return found output minarg maxarg) + name = ecl_symbol_name(symbol); + is_symbol = Null(as_function); + if (is_symbol) { + cl_fixnum p; + if (symbol == ECL_NIL) + @(return ECL_T make_constant_base_string("ECL_NIL")) + else if (symbol == ECL_T) + @(return ECL_T make_constant_base_string("ECL_T")) + p = (cl_symbol_initializer*)symbol - cl_symbols; + if (p >= 0 && p <= cl_num_symbols_in_core) { + found = ECL_T; + output = cl_format(4, ECL_NIL, + make_constant_base_string("ECL_SYM(~S,~D)"), + name, ecl_make_fixnum(p)); + @(return found output maxarg) + } + } else if (!Null(symbol)) { + cl_object fun = symbol->symbol.gfdef; + cl_type t = (fun == OBJNULL)? t_other : type_of(fun); + if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { + for (l = 0; l <= cl_num_symbols_in_core; l++) { + cl_object s = (cl_object)(cl_symbols + l); + if (fun == ECL_SYM_FUN(s)) { + symbol = s; + found = ECL_T; + if (fun->cfun.narg >= 0) { + minarg = + maxarg = ecl_make_fixnum(fun->cfun.narg); + } + break; + } + } + } + } + package = ecl_symbol_package(symbol); + if (Null(package)) + ; + else if (package == cl_core.lisp_package) + package = make_constant_base_string("cl"); + else if (package == cl_core.system_package) + package = make_constant_base_string("si"); + else if (package == cl_core.ext_package) + package = make_constant_base_string("si"); + else if (package == cl_core.keyword_package) + package = ECL_NIL; + else + package = package->pack.name; + symbol = ecl_symbol_name(symbol); + l = symbol->base_string.fillp; + source = symbol->base_string.self; + output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1); + if (is_symbol && source[0] == '*') { + if (l > 2 && source[l-1] == '*') l--; + c = 'V'; + l--; + source++; + } else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') { + c = 'C'; + l-= 2; + source++; + } else if (!is_symbol) { + c = '_'; + } else if (package == cl_core.keyword_package) { + c = 'K'; + } else { + c = 'S'; + } + output->base_string.fillp = 0; + if (!Null(package)) + if (!mangle_name(output, package->base_string.self, package->base_string.fillp)) + @(return ECL_NIL ECL_NIL maxarg) + output->base_string.self[output->base_string.fillp++] = c; + if (!(dest = mangle_name(output, source, l))) + @(return ECL_NIL ECL_NIL maxarg) + if (dest[-1] == '_') + dest[-1] = 'M'; + *(dest++) = '\0'; + @(return found output minarg maxarg) @) static void make_this_symbol(int i, cl_object s, int code, const char *name, - cl_objectfn fun, int narg, cl_object value) + cl_objectfn fun, int narg, cl_object value) { - enum ecl_stype stp; - cl_object package; - bool form = 0; + enum ecl_stype stp; + cl_object package; + bool form = 0; - switch (code & 3) { - case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break; - case SPECIAL_SYMBOL: stp = ecl_stp_special; break; - case CONSTANT_SYMBOL: stp = ecl_stp_constant; break; - case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary; - } - switch (code & 0xfc) { - case CL_PACKAGE: package = cl_core.lisp_package; break; - case SI_PACKAGE: package = cl_core.system_package; break; - case EXT_PACKAGE: package = cl_core.ext_package; break; - case KEYWORD_PACKAGE: package = cl_core.keyword_package; break; - case MP_PACKAGE: package = cl_core.mp_package; break; + switch (code & 3) { + case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break; + case SPECIAL_SYMBOL: stp = ecl_stp_special; break; + case CONSTANT_SYMBOL: stp = ecl_stp_constant; break; + case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary; + } + switch (code & 0xfc) { + case CL_PACKAGE: package = cl_core.lisp_package; break; + case SI_PACKAGE: package = cl_core.system_package; break; + case EXT_PACKAGE: package = cl_core.ext_package; break; + case KEYWORD_PACKAGE: package = cl_core.keyword_package; break; + case MP_PACKAGE: package = cl_core.mp_package; break; #ifdef CLOS - case CLOS_PACKAGE: package = cl_core.clos_package; break; + case CLOS_PACKAGE: package = cl_core.clos_package; break; #endif #ifdef ECL_CLOS_STREAMS - case GRAY_PACKAGE: package = cl_core.gray_package; break; + case GRAY_PACKAGE: package = cl_core.gray_package; break; #endif - case FFI_PACKAGE: package = cl_core.ffi_package; break; - default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()"); - } - s->symbol.t = t_symbol; - s->symbol.dynamic = 0; + case FFI_PACKAGE: package = cl_core.ffi_package; break; + default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()"); + } + s->symbol.t = t_symbol; + s->symbol.dynamic = 0; #ifdef ECL_THREADS - s->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + s->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - ECL_SET(s, OBJNULL); - ECL_SYM_FUN(s) = ECL_NIL; - s->symbol.plist = ECL_NIL; - s->symbol.hpack = ECL_NIL; - s->symbol.stype = stp; - s->symbol.hpack = package; - s->symbol.name = make_constant_base_string(name); - if (package == cl_core.keyword_package) { - package->pack.external = + ECL_SET(s, OBJNULL); + ECL_SYM_FUN(s) = ECL_NIL; + s->symbol.plist = ECL_NIL; + s->symbol.hpack = ECL_NIL; + s->symbol.stype = stp; + s->symbol.hpack = package; + s->symbol.name = make_constant_base_string(name); + if (package == cl_core.keyword_package) { + package->pack.external = _ecl_sethash(s->symbol.name, package->pack.external, s); - ECL_SET(s, s); - } else { - int intern_flag; - ECL_SET(s, value); - if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL - && intern_flag == ECL_INHERITED) { - ecl_shadowing_import(s, package); - } else { - cl_import2(s, package); - } - if (!(code & PRIVATE)) { - cl_export2(s, package); - if (package == cl_core.ext_package) - cl_export2(s, cl_core.system_package); - } - } - if (form) { - s->symbol.stype |= ecl_stp_special_form; - } else if (fun) { - cl_object f; - if (narg >= 0) { - f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg); - } else { - f = ecl_make_cfun_va(fun, s, NULL); - } - ECL_SYM_FUN(s) = f; - } - cl_num_symbols_in_core = i + 1; + ECL_SET(s, s); + } else { + int intern_flag; + ECL_SET(s, value); + if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL + && intern_flag == ECL_INHERITED) { + ecl_shadowing_import(s, package); + } else { + cl_import2(s, package); + } + if (!(code & PRIVATE)) { + cl_export2(s, package); + if (package == cl_core.ext_package) + cl_export2(s, cl_core.system_package); + } + } + if (form) { + s->symbol.stype |= ecl_stp_special_form; + } else if (fun) { + cl_object f; + if (narg >= 0) { + f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg); + } else { + f = ecl_make_cfun_va(fun, s, NULL); + } + ECL_SYM_FUN(s) = f; + } + cl_num_symbols_in_core = i + 1; } void init_all_symbols(void) { - int i, code, narg; - const char *name; - cl_object s, value; - cl_objectfn fun; + int i, code, narg; + const char *name; + cl_object s, value; + cl_objectfn fun; - /* We skip NIL and T */ - for (i = 2; cl_symbols[i].init.name != NULL; i++) { - s = (cl_object)(cl_symbols + i); - code = cl_symbols[i].init.type; - name = cl_symbols[i].init.name; - fun = (cl_objectfn)cl_symbols[i].init.fun; - narg = cl_symbols[i].init.narg; - value = cl_symbols[i].init.value; - make_this_symbol(i, s, code, name, fun, narg, value); - } + /* We skip NIL and T */ + for (i = 2; cl_symbols[i].init.name != NULL; i++) { + s = (cl_object)(cl_symbols + i); + code = cl_symbols[i].init.type; + name = cl_symbols[i].init.name; + fun = (cl_objectfn)cl_symbols[i].init.fun; + narg = cl_symbols[i].init.narg; + value = cl_symbols[i].init.value; + make_this_symbol(i, s, code, name, fun, narg, value); + } } diff --git a/src/c/alloc.d b/src/c/alloc.d index 71874480e..a508237a8 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -1,7 +1,7 @@ /* -*- mode: c; c-basic-offset: 8 -*- */ /* - alloc.c -- Memory allocation. + alloc.c -- Memory allocation. */ /* Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. @@ -27,9 +27,9 @@ ********************************************************************************/ /* - Heap and Relocatable Area + Heap and Relocatable Area - heap_end data_end + heap_end data_end +------+--------------------+ - - - + - - --------+ | text | heap | hole | stack | +------+--------------------+ - - - + - - --------+ @@ -71,15 +71,15 @@ char type_map[MAXPAGE]; struct typemanager tm_table[(int)t_end]; struct contblock *cb_pointer = NULL; -cl_index ncb; /* number of contblocks */ -cl_index ncbpage; /* number of contblock pages */ -cl_index maxcbpage; /* maximum number of contblock pages */ -cl_index cbgccount; /* contblock gc count */ -cl_index holepage; /* hole pages */ +cl_index ncb; /* number of contblocks */ +cl_index ncbpage; /* number of contblock pages */ +cl_index maxcbpage; /* maximum number of contblock pages */ +cl_index cbgccount; /* contblock gc count */ +cl_index holepage; /* hole pages */ -cl_ptr heap_end; /* heap end */ -cl_ptr heap_start; /* heap start */ -cl_ptr data_end; /* end of data space */ +cl_ptr heap_end; /* heap end */ +cl_ptr heap_start; /* heap start */ +cl_ptr data_end; /* end of data space */ /******************************* ------- ******************************/ @@ -99,81 +99,81 @@ void cl_resize_hole(cl_index n) { #define PAGESIZE 8192 - cl_index m, bytes; - cl_ptr result, last_addr; - bytes = n * LISP_PAGESIZE; - bytes = (bytes + PAGESIZE-1) / PAGESIZE; - bytes = bytes * PAGESIZE; - if (heap_start == NULL) { - /* First time use. We allocate the memory and keep the first - * address in heap_start. - */ - result = mmap(0x2E000000, bytes, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1 ,0); - if (result == MAP_FAILED) - ecl_internal_error("Cannot allocate memory. Good-bye!"); - data_end = heap_end = heap_start = result; - last_addr = heap_start + bytes; - holepage = n; - } else { - /* Next time use. We extend the region of memory that we had - * mapped before. - */ - m = (data_end - heap_end)/LISP_PAGESIZE; - if (n <= m) - return; - result = mmap(data_end, bytes, PROT_READ | PROT_WRITE, - MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1, 0); - if (result == MAP_FAILED) - ecl_internal_error("Cannot resize memory pool. Good-bye!"); - last_addr = result + bytes; - if (result != data_end) { - cl_dealloc(heap_end, data_end - heap_end); - while (heap_end < result) { - cl_index p = page(heap_end); - if (p > real_maxpage) - ecl_internal_error("Memory limit exceeded."); - type_map[p] = t_other; - heap_end += LISP_PAGESIZE; - } - } - holepage = (last_addr - heap_end) / LISP_PAGESIZE; - } - while (data_end < last_addr) { - type_map[page(data_end)] = t_other; - data_end += LISP_PAGESIZE; - } + cl_index m, bytes; + cl_ptr result, last_addr; + bytes = n * LISP_PAGESIZE; + bytes = (bytes + PAGESIZE-1) / PAGESIZE; + bytes = bytes * PAGESIZE; + if (heap_start == NULL) { + /* First time use. We allocate the memory and keep the first + * address in heap_start. + */ + result = mmap(0x2E000000, bytes, PROT_READ | PROT_WRITE, + MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1 ,0); + if (result == MAP_FAILED) + ecl_internal_error("Cannot allocate memory. Good-bye!"); + data_end = heap_end = heap_start = result; + last_addr = heap_start + bytes; + holepage = n; + } else { + /* Next time use. We extend the region of memory that we had + * mapped before. + */ + m = (data_end - heap_end)/LISP_PAGESIZE; + if (n <= m) + return; + result = mmap(data_end, bytes, PROT_READ | PROT_WRITE, + MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1, 0); + if (result == MAP_FAILED) + ecl_internal_error("Cannot resize memory pool. Good-bye!"); + last_addr = result + bytes; + if (result != data_end) { + cl_dealloc(heap_end, data_end - heap_end); + while (heap_end < result) { + cl_index p = page(heap_end); + if (p > real_maxpage) + ecl_internal_error("Memory limit exceeded."); + type_map[p] = t_other; + heap_end += LISP_PAGESIZE; + } + } + holepage = (last_addr - heap_end) / LISP_PAGESIZE; + } + while (data_end < last_addr) { + type_map[page(data_end)] = t_other; + data_end += LISP_PAGESIZE; + } } #else void cl_resize_hole(cl_index n) { - cl_ptr e; - cl_index m; - m = (data_end - heap_end)/LISP_PAGESIZE; - if (n <= m) - return; + cl_ptr e; + cl_index m; + m = (data_end - heap_end)/LISP_PAGESIZE; + if (n <= m) + return; - /* Create the hole */ - e = sbrk(0); - if (data_end == e) { - e = sbrk((n -= m) * LISP_PAGESIZE); - } else { - cl_dealloc(heap_end, data_end - heap_end); - /* FIXME! Horrible hack! */ - /* mark as t_other pages not allocated by us */ - heap_end = e; - while (data_end < heap_end) { - type_map[page(data_end)] = t_other; - data_end += LISP_PAGESIZE; - } - holepage = 0; - e = sbrk(n * LISP_PAGESIZE + (data_end - e)); - } - if ((cl_fixnum)e < 0) - ecl_internal_error("Can't allocate. Good-bye!"); - data_end = e; - holepage += n; + /* Create the hole */ + e = sbrk(0); + if (data_end == e) { + e = sbrk((n -= m) * LISP_PAGESIZE); + } else { + cl_dealloc(heap_end, data_end - heap_end); + /* FIXME! Horrible hack! */ + /* mark as t_other pages not allocated by us */ + heap_end = e; + while (data_end < heap_end) { + type_map[page(data_end)] = t_other; + data_end += LISP_PAGESIZE; + } + holepage = 0; + e = sbrk(n * LISP_PAGESIZE + (data_end - e)); + } + if ((cl_fixnum)e < 0) + ecl_internal_error("Can't allocate. Good-bye!"); + data_end = e; + holepage += n; } #endif @@ -181,14 +181,14 @@ cl_resize_hole(cl_index n) static void * alloc_page(cl_index n) { - cl_ptr e = heap_end; - if (n >= holepage) { - ecl_gc(t_contiguous); - cl_resize_hole(new_holepage+n); - } - holepage -= n; - heap_end += LISP_PAGESIZE*n; - return e; + cl_ptr e = heap_end; + if (n >= holepage) { + ecl_gc(t_contiguous); + cl_resize_hole(new_holepage+n); + } + holepage -= n; + heap_end += LISP_PAGESIZE*n; + return e; } /* @@ -200,396 +200,396 @@ alloc_page(cl_index n) static void add_page_to_freelist(cl_ptr p, struct typemanager *tm) { - cl_type t; - cl_object x, f; - cl_index i; - t = tm->tm_type; - type_map[page(p)] = t; - f = tm->tm_free; - for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) { - x = (cl_object)p; - ((struct freelist *)x)->t = (short)t; - ((struct freelist *)x)->m = FREE; - ((struct freelist *)x)->f_link = f; - f = x; - } - /* Mark the extra bytes which cannot be used. */ - if (tm->tm_size * tm->tm_nppage < LISP_PAGESIZE) { - x = (cl_object)p; - x->d.m = FREE; - } - tm->tm_free = f; - tm->tm_nfree += tm->tm_nppage; - tm->tm_npage++; + cl_type t; + cl_object x, f; + cl_index i; + t = tm->tm_type; + type_map[page(p)] = t; + f = tm->tm_free; + for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) { + x = (cl_object)p; + ((struct freelist *)x)->t = (short)t; + ((struct freelist *)x)->m = FREE; + ((struct freelist *)x)->f_link = f; + f = x; + } + /* Mark the extra bytes which cannot be used. */ + if (tm->tm_size * tm->tm_nppage < LISP_PAGESIZE) { + x = (cl_object)p; + x->d.m = FREE; + } + tm->tm_free = f; + tm->tm_nfree += tm->tm_nppage; + tm->tm_npage++; } cl_object ecl_alloc_object(cl_type t) { - register cl_object obj; - register struct typemanager *tm; - register cl_ptr p; + register cl_object obj; + register struct typemanager *tm; + register cl_ptr p; - switch (t) { - case t_fixnum: - return MAKE_FIXNUM(0); /* Immediate fixnum */ - case t_character: - return ECL_CODE_CHAR('\0'); /* Immediate character */ - default:; - } + switch (t) { + case t_fixnum: + return MAKE_FIXNUM(0); /* Immediate fixnum */ + case t_character: + return ECL_CODE_CHAR('\0'); /* Immediate character */ + default:; + } - ecl_disable_interrupts(); - tm = tm_of(t); + ecl_disable_interrupts(); + tm = tm_of(t); ONCE_MORE: - obj = tm->tm_free; - if (obj == OBJNULL) { - cl_index available = available_pages(); - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - if (available < 1) { - ignore_maximum_pages = FALSE; - goto CALL_GC; - } - p = alloc_page(1); - add_page_to_freelist(p, tm); - obj = tm->tm_free; - /* why this? Beppe - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; */ - } - tm->tm_free = ((struct freelist *)obj)->f_link; - --(tm->tm_nfree); - (tm->tm_nused)++; - obj->d.t = (short)t; - obj->d.m = FALSE; - /* Now initialize the object so that it can be correctly marked - * by the GC - */ - switch (t) { - case t_bignum: - ECL_BIGNUM_DIM(obj) = ECL_BIGNUM_SIZE(obj) = 0; - ECL_BIGNUM_LIMBS(obj) = NULL; - break; - case t_ratio: - obj->ratio.num = OBJNULL; - obj->ratio.den = OBJNULL; - break; + obj = tm->tm_free; + if (obj == OBJNULL) { + cl_index available = available_pages(); + if (tm->tm_npage >= tm->tm_maxpage) + goto CALL_GC; + if (available < 1) { + ignore_maximum_pages = FALSE; + goto CALL_GC; + } + p = alloc_page(1); + add_page_to_freelist(p, tm); + obj = tm->tm_free; + /* why this? Beppe + if (tm->tm_npage >= tm->tm_maxpage) + goto CALL_GC; */ + } + tm->tm_free = ((struct freelist *)obj)->f_link; + --(tm->tm_nfree); + (tm->tm_nused)++; + obj->d.t = (short)t; + obj->d.m = FALSE; + /* Now initialize the object so that it can be correctly marked + * by the GC + */ + switch (t) { + case t_bignum: + ECL_BIGNUM_DIM(obj) = ECL_BIGNUM_SIZE(obj) = 0; + ECL_BIGNUM_LIMBS(obj) = NULL; + break; + case t_ratio: + obj->ratio.num = OBJNULL; + obj->ratio.den = OBJNULL; + break; #ifdef ECL_SSE2 - case t_sse_pack: + case t_sse_pack: #endif - case t_singlefloat: - case t_doublefloat: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - break; - case t_complex: - obj->complex.imag = OBJNULL; - obj->complex.real = OBJNULL; - break; - case t_symbol: - obj->symbol.plist = OBJNULL; - obj->symbol.gfdef = OBJNULL; - obj->symbol.value = OBJNULL; - obj->symbol.name = OBJNULL; - obj->symbol.hpack = OBJNULL; - break; - case t_package: - obj->pack.name = OBJNULL; - obj->pack.nicknames = OBJNULL; - obj->pack.shadowings = OBJNULL; - obj->pack.uses = OBJNULL; - obj->pack.usedby = OBJNULL; - obj->pack.internal = OBJNULL; - obj->pack.external = OBJNULL; - break; - case t_cons: -#error "FIXME" - obj->cons.car = OBJNULL; - obj->cons.cdr = OBJNULL; - break; - case t_hashtable: - obj->hash.rehash_size = OBJNULL; - obj->hash.threshold = OBJNULL; - obj->hash.data = NULL; - break; - case t_array: - obj->array.dims = NULL; - obj->array.displaced = ECL_NIL; - obj->array.elttype = (short)ecl_aet_object; - obj->array.self.t = NULL; - break; + break; + case t_complex: + obj->complex.imag = OBJNULL; + obj->complex.real = OBJNULL; + break; + case t_symbol: + obj->symbol.plist = OBJNULL; + obj->symbol.gfdef = OBJNULL; + obj->symbol.value = OBJNULL; + obj->symbol.name = OBJNULL; + obj->symbol.hpack = OBJNULL; + break; + case t_package: + obj->pack.name = OBJNULL; + obj->pack.nicknames = OBJNULL; + obj->pack.shadowings = OBJNULL; + obj->pack.uses = OBJNULL; + obj->pack.usedby = OBJNULL; + obj->pack.internal = OBJNULL; + obj->pack.external = OBJNULL; + break; + case t_cons: +#error "FIXME" + obj->cons.car = OBJNULL; + obj->cons.cdr = OBJNULL; + break; + case t_hashtable: + obj->hash.rehash_size = OBJNULL; + obj->hash.threshold = OBJNULL; + obj->hash.data = NULL; + break; + case t_array: + obj->array.dims = NULL; + obj->array.displaced = ECL_NIL; + obj->array.elttype = (short)ecl_aet_object; + obj->array.self.t = NULL; + break; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - obj->array.displaced = ECL_NIL; - obj->array.elttype = (short)ecl_aet_object; - obj->array.self.t = NULL; - break; - case t_base_string: - obj->base_string.displaced = ECL_NIL; - obj->base_string.self = NULL; - break; - case t_bitvector: - obj->vector.displaced = ECL_NIL; - obj->vector.self.bit = NULL; - break; + case t_vector: + obj->array.displaced = ECL_NIL; + obj->array.elttype = (short)ecl_aet_object; + obj->array.self.t = NULL; + break; + case t_base_string: + obj->base_string.displaced = ECL_NIL; + obj->base_string.self = NULL; + break; + case t_bitvector: + obj->vector.displaced = ECL_NIL; + obj->vector.self.bit = NULL; + break; #ifndef CLOS - case t_structure: - obj->str.name = OBJNULL; - obj->str.self = NULL; - break; + case t_structure: + obj->str.name = OBJNULL; + obj->str.self = NULL; + break; #endif /* CLOS */ - case t_stream: - obj->stream.mode = (short)ecl_smm_broadcast; - obj->stream.file.descriptor = -1; - obj->stream.object0 = OBJNULL; - obj->stream.object1 = OBJNULL; - obj->stream.buffer = NULL; - break; - case t_random: - break; - case t_readtable: - obj->readtable.table = NULL; - break; - case t_pathname: - obj->pathname.host = OBJNULL; - obj->pathname.device = OBJNULL; - obj->pathname.directory = OBJNULL; - obj->pathname.name = OBJNULL; - obj->pathname.type = OBJNULL; - obj->pathname.version = OBJNULL; - break; - case t_bytecodes: - obj->bytecodes.lex = ECL_NIL; - obj->bytecodes.name = ECL_NIL; - obj->bytecodes.definition = ECL_NIL; - obj->bytecodes.specials = ECL_NIL; - obj->bytecodes.code_size = 0; - obj->bytecodes.code = NULL; - obj->bytecodes.data = NULL; - break; - case t_bclosure: - obj->bclosure.code = - obj->bclosure.lex = ECL_NIL; - break; - case t_cfun: - case t_cfunfixed: - obj->cfun.name = OBJNULL; - obj->cfun.block = NULL; - break; - case t_cclosure: - obj->cclosure.env = OBJNULL; - obj->cclosure.block = NULL; - break; + case t_stream: + obj->stream.mode = (short)ecl_smm_broadcast; + obj->stream.file.descriptor = -1; + obj->stream.object0 = OBJNULL; + obj->stream.object1 = OBJNULL; + obj->stream.buffer = NULL; + break; + case t_random: + break; + case t_readtable: + obj->readtable.table = NULL; + break; + case t_pathname: + obj->pathname.host = OBJNULL; + obj->pathname.device = OBJNULL; + obj->pathname.directory = OBJNULL; + obj->pathname.name = OBJNULL; + obj->pathname.type = OBJNULL; + obj->pathname.version = OBJNULL; + break; + case t_bytecodes: + obj->bytecodes.lex = ECL_NIL; + obj->bytecodes.name = ECL_NIL; + obj->bytecodes.definition = ECL_NIL; + obj->bytecodes.specials = ECL_NIL; + obj->bytecodes.code_size = 0; + obj->bytecodes.code = NULL; + obj->bytecodes.data = NULL; + break; + case t_bclosure: + obj->bclosure.code = + obj->bclosure.lex = ECL_NIL; + break; + case t_cfun: + case t_cfunfixed: + obj->cfun.name = OBJNULL; + obj->cfun.block = NULL; + break; + case t_cclosure: + obj->cclosure.env = OBJNULL; + obj->cclosure.block = NULL; + break; /* - case t_spice: - break; + case t_spice: + break; */ #ifdef ECL_THREADS - case t_process: - obj->process.name = OBJNULL; - obj->process.function = OBJNULL; - obj->process.args = OBJNULL; - obj->process.env = NULL; - obj->process.interrupt = OBJNULL; - break; - case t_lock: - obj->lock.mutex = OBJNULL; - case t_condition_variable: - obj->condition_variable.cv = OBJNULL; - break; + case t_process: + obj->process.name = OBJNULL; + obj->process.function = OBJNULL; + obj->process.args = OBJNULL; + obj->process.env = NULL; + obj->process.interrupt = OBJNULL; + break; + case t_lock: + obj->lock.mutex = OBJNULL; + case t_condition_variable: + obj->condition_variable.cv = OBJNULL; + break; #endif #ifdef ECL_SEMAPHORES - case t_semaphore: + case t_semaphore: obj->semaphore.handle = NULL; - break; + break; #endif #ifdef CLOS - case t_instance: - obj->instance.length = 0; - ECL_CLASS_OF(obj) = OBJNULL; - obj->instance.sig = ECL_NIL; - obj->instance.isgf = 0; - obj->instance.slots = NULL; - break; + case t_instance: + obj->instance.length = 0; + ECL_CLASS_OF(obj) = OBJNULL; + obj->instance.sig = ECL_NIL; + obj->instance.isgf = 0; + obj->instance.slots = NULL; + break; #endif /* CLOS */ - case t_codeblock: - obj->cblock.locked = 0; - obj->cblock.name = ECL_NIL; - obj->cblock.handle = NULL; - obj->cblock.entry = NULL; - obj->cblock.data = NULL; - obj->cblock.data_size = 0; - obj->cblock.data_text = NULL; - obj->cblock.data_text_size = 0; - obj->cblock.links = ECL_NIL; - obj->cblock.next = ECL_NIL; - break; - case t_foreign: - obj->foreign.tag = ECL_NIL; - obj->foreign.size = 0; - obj->foreign.data = NULL; - break; - default: - printf("\ttype = %d\n", t); - ecl_internal_error("alloc botch."); - } - ecl_enable_interrupts(); - return(obj); + case t_codeblock: + obj->cblock.locked = 0; + obj->cblock.name = ECL_NIL; + obj->cblock.handle = NULL; + obj->cblock.entry = NULL; + obj->cblock.data = NULL; + obj->cblock.data_size = 0; + obj->cblock.data_text = NULL; + obj->cblock.data_text_size = 0; + obj->cblock.links = ECL_NIL; + obj->cblock.next = ECL_NIL; + break; + case t_foreign: + obj->foreign.tag = ECL_NIL; + obj->foreign.size = 0; + obj->foreign.data = NULL; + break; + default: + printf("\ttype = %d\n", t); + ecl_internal_error("alloc botch."); + } + ecl_enable_interrupts(); + return(obj); CALL_GC: - ecl_gc(tm->tm_type); - if (tm->tm_nfree != 0 && - (float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused) - goto ONCE_MORE; + ecl_gc(tm->tm_type); + if (tm->tm_nfree != 0 && + (float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused) + goto ONCE_MORE; -/* EXHAUSTED: */ - if (ignore_maximum_pages) { - if (tm->tm_maxpage/2 <= 0) - tm->tm_maxpage += 1; - else - tm->tm_maxpage += tm->tm_maxpage/2; - goto ONCE_MORE; - } - GC_disable(); - { cl_object s = ecl_make_simple_base_string(tm_table[(int)t].tm_name+1, -1); - GC_enable(); - CEerror(ECL_T, "The storage for ~A is exhausted.~%\ +/* EXHAUSTED: */ + if (ignore_maximum_pages) { + if (tm->tm_maxpage/2 <= 0) + tm->tm_maxpage += 1; + else + tm->tm_maxpage += tm->tm_maxpage/2; + goto ONCE_MORE; + } + GC_disable(); + { cl_object s = ecl_make_simple_base_string(tm_table[(int)t].tm_name+1, -1); + GC_enable(); + CEerror(ECL_T, "The storage for ~A is exhausted.~%\ Currently, ~D pages are allocated.~%\ Use ALLOCATE to expand the space.", - 2, s, MAKE_FIXNUM(tm->tm_npage)); - } - goto ONCE_MORE; + 2, s, MAKE_FIXNUM(tm->tm_npage)); + } + goto ONCE_MORE; } cl_object ecl_cons(cl_object a, cl_object d) { - register cl_object obj; - register cl_ptr p; - struct typemanager *tm=(&tm_table[(int)t_cons]); + register cl_object obj; + register cl_ptr p; + struct typemanager *tm=(&tm_table[(int)t_cons]); - ecl_disable_interrupts(); + ecl_disable_interrupts(); ONCE_MORE: - obj = tm->tm_free; - if (obj == OBJNULL) { - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - if (available_pages() < 1) { - ignore_maximum_pages = FALSE; - goto CALL_GC; - } - p = alloc_page(1); - add_page_to_freelist(p,tm); - obj = tm->tm_free; - if (tm->tm_npage >= tm->tm_maxpage) - goto CALL_GC; - } - tm->tm_free = ((struct freelist *)obj)->f_link; - --(tm->tm_nfree); - (tm->tm_nused)++; - obj->d.t = (short)t_cons; - obj->d.m = FALSE; - obj->cons.car = a; - obj->cons.cdr = d; + obj = tm->tm_free; + if (obj == OBJNULL) { + if (tm->tm_npage >= tm->tm_maxpage) + goto CALL_GC; + if (available_pages() < 1) { + ignore_maximum_pages = FALSE; + goto CALL_GC; + } + p = alloc_page(1); + add_page_to_freelist(p,tm); + obj = tm->tm_free; + if (tm->tm_npage >= tm->tm_maxpage) + goto CALL_GC; + } + tm->tm_free = ((struct freelist *)obj)->f_link; + --(tm->tm_nfree); + (tm->tm_nused)++; + obj->d.t = (short)t_cons; + obj->d.m = FALSE; + obj->cons.car = a; + obj->cons.cdr = d; - ecl_enable_interrupts(); - return(obj); + ecl_enable_interrupts(); + return(obj); CALL_GC: - ecl_gc(t_cons); - if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused)) - goto ONCE_MORE; + ecl_gc(t_cons); + if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused)) + goto ONCE_MORE; -/* EXHAUSTED: */ - if (ignore_maximum_pages) { - if (tm->tm_maxpage/2 <= 0) - tm->tm_maxpage += 1; - else - tm->tm_maxpage += tm->tm_maxpage/2; - goto ONCE_MORE; - } - CEerror(ECL_T, "The storage for CONS is exhausted.~%\ +/* EXHAUSTED: */ + if (ignore_maximum_pages) { + if (tm->tm_maxpage/2 <= 0) + tm->tm_maxpage += 1; + else + tm->tm_maxpage += tm->tm_maxpage/2; + goto ONCE_MORE; + } + CEerror(ECL_T, "The storage for CONS is exhausted.~%\ Currently, ~D pages are allocated.~%\ Use ALLOCATE to expand the space.", - 1, MAKE_FIXNUM(tm->tm_npage)); - goto ONCE_MORE; -#undef tm + 1, MAKE_FIXNUM(tm->tm_npage)); + goto ONCE_MORE; +#undef tm } cl_object ecl_alloc_instance(cl_index slots) { - cl_object i = ecl_alloc_object(t_instance); - if (slots >= ECL_SLOTS_LIMIT) - FEerror("Limit on instance size exceeded: ~S slots requested.", - 1, MAKE_FIXNUM(slots)); - /* INV: slots > 0 */ - i->instance.slots = (cl_object*)ecl_alloc(sizeof(cl_object) * slots); - i->instance.length = slots; - return i; + cl_object i = ecl_alloc_object(t_instance); + if (slots >= ECL_SLOTS_LIMIT) + FEerror("Limit on instance size exceeded: ~S slots requested.", + 1, MAKE_FIXNUM(slots)); + /* INV: slots > 0 */ + i->instance.slots = (cl_object*)ecl_alloc(sizeof(cl_object) * slots); + i->instance.length = slots; + return i; } void * ecl_alloc(cl_index n) { - volatile cl_ptr p; - struct contblock **cbpp; - cl_index i, m; - bool g; + volatile cl_ptr p; + struct contblock **cbpp; + cl_index i, m; + bool g; - g = FALSE; - n = round_up(n); + g = FALSE; + n = round_up(n); - ecl_disable_interrupts(); + ecl_disable_interrupts(); ONCE_MORE: - /* Use extra indirection so that cb_pointer can be updated */ - for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) - if ((*cbpp)->cb_size >= n) { - p = (cl_ptr)(*cbpp); - i = (*cbpp)->cb_size - n; - *cbpp = (*cbpp)->cb_link; - --ncb; - cl_dealloc(p+n, i); + /* Use extra indirection so that cb_pointer can be updated */ + for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) + if ((*cbpp)->cb_size >= n) { + p = (cl_ptr)(*cbpp); + i = (*cbpp)->cb_size - n; + *cbpp = (*cbpp)->cb_link; + --ncb; + cl_dealloc(p+n, i); - ecl_enable_interrupts(); - return(p); - } - m = round_to_page(n); - if (ncbpage + m > maxcbpage || available_pages() < m) { - if (available_pages() < m) - ignore_maximum_pages = FALSE; - if (!g) { - ecl_gc(t_contiguous); - g = TRUE; - goto ONCE_MORE; - } - if (ignore_maximum_pages) { - if (maxcbpage/2 <= 0) - maxcbpage += 1; - else - maxcbpage += maxcbpage/2; - g = FALSE; - goto ONCE_MORE; - } - CEerror(ECL_T, "Contiguous blocks exhausted.~%\ + ecl_enable_interrupts(); + return(p); + } + m = round_to_page(n); + if (ncbpage + m > maxcbpage || available_pages() < m) { + if (available_pages() < m) + ignore_maximum_pages = FALSE; + if (!g) { + ecl_gc(t_contiguous); + g = TRUE; + goto ONCE_MORE; + } + if (ignore_maximum_pages) { + if (maxcbpage/2 <= 0) + maxcbpage += 1; + else + maxcbpage += maxcbpage/2; + g = FALSE; + goto ONCE_MORE; + } + CEerror(ECL_T, "Contiguous blocks exhausted.~%\ Currently, ~D pages are allocated.~%\ Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.", - 1, MAKE_FIXNUM(ncbpage)); - g = FALSE; - goto ONCE_MORE; - } - p = alloc_page(m); + 1, MAKE_FIXNUM(ncbpage)); + g = FALSE; + goto ONCE_MORE; + } + p = alloc_page(m); - for (i = 0; i < m; i++) - type_map[page(p) + i] = (char)t_contiguous; - ncbpage += m; - cl_dealloc(p+n, LISP_PAGESIZE*m - n); + for (i = 0; i < m; i++) + type_map[page(p) + i] = (char)t_contiguous; + ncbpage += m; + cl_dealloc(p+n, LISP_PAGESIZE*m - n); - ecl_enable_interrupts(); - return memset(p, 0, n); + ecl_enable_interrupts(); + return memset(p, 0, n); } /* @@ -599,21 +599,21 @@ Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.", void cl_dealloc(void *p, cl_index s) { - struct contblock **cbpp, *cbp; + struct contblock **cbpp, *cbp; - if (s < CBMINSIZE) - return; - ncb++; - cbp = (struct contblock *)p; - cbp->cb_size = s; - for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link)) - if ((*cbpp)->cb_size >= s) { - cbp->cb_link = *cbpp; - *cbpp = cbp; - return; - } - cbp->cb_link = NULL; - *cbpp = cbp; + if (s < CBMINSIZE) + return; + ncb++; + cbp = (struct contblock *)p; + cbp->cb_size = s; + for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link)) + if ((*cbpp)->cb_size >= s) { + cbp->cb_link = *cbpp; + *cbpp = cbp; + return; + } + cbp->cb_link = NULL; + *cbpp = cbp; } /* @@ -623,47 +623,47 @@ cl_dealloc(void *p, cl_index s) void * ecl_alloc_align(cl_index size, cl_index align) { - void *output; - ecl_disable_interrupts(); - align--; - if (align) - output = (void*)(((cl_index)ecl_alloc(size + align) + align - 1) & ~align); - else - output = ecl_alloc(size); - ecl_enable_interrupts(); - return output; + void *output; + ecl_disable_interrupts(); + align--; + if (align) + output = (void*)(((cl_index)ecl_alloc(size + align) + align - 1) & ~align); + else + output = ecl_alloc(size); + ecl_enable_interrupts(); + return output; } static void init_tm(cl_type t, const char *name, cl_index elsize, cl_index maxpage) { - int i, j; - struct typemanager *tm = &tm_table[(int)t]; + int i, j; + struct typemanager *tm = &tm_table[(int)t]; - if (elsize < 2*sizeof(cl_index)) { - // A free list cell does not fit into this type - elsize = 2*sizeof(cl_index); - } + if (elsize < 2*sizeof(cl_index)) { + // A free list cell does not fit into this type + elsize = 2*sizeof(cl_index); + } - tm->tm_name = name; - for (i = (int)t_start, j = i-1; i < (int)t_end; i++) - if (tm_table[i].tm_size >= elsize && - (j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size)) - j = i; - if (j >= (int)t_start) { - tm->tm_type = (cl_type)j; - tm_table[j].tm_maxpage += maxpage; - return; - } - tm->tm_type = t; - tm->tm_size = round_up(elsize); - tm->tm_nppage = LISP_PAGESIZE/round_up(elsize); - tm->tm_free = OBJNULL; - tm->tm_nfree = 0; - tm->tm_nused = 0; - tm->tm_npage = 0; - tm->tm_maxpage = maxpage; - tm->tm_gccount = 0; + tm->tm_name = name; + for (i = (int)t_start, j = i-1; i < (int)t_end; i++) + if (tm_table[i].tm_size >= elsize && + (j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size)) + j = i; + if (j >= (int)t_start) { + tm->tm_type = (cl_type)j; + tm_table[j].tm_maxpage += maxpage; + return; + } + tm->tm_type = t; + tm->tm_size = round_up(elsize); + tm->tm_nppage = LISP_PAGESIZE/round_up(elsize); + tm->tm_free = OBJNULL; + tm->tm_nfree = 0; + tm->tm_nused = 0; + tm->tm_npage = 0; + tm->tm_maxpage = maxpage; + tm->tm_gccount = 0; } static int alloc_initialized = FALSE; @@ -671,109 +671,109 @@ static int alloc_initialized = FALSE; void init_alloc(void) { - cl_index i; + cl_index i; - if (alloc_initialized) return; - alloc_initialized = TRUE; + if (alloc_initialized) return; + alloc_initialized = TRUE; - holepage = 0; - new_holepage = HOLEPAGE; + holepage = 0; + new_holepage = HOLEPAGE; #ifdef USE_MMAP - real_maxpage = MAXPAGE; + real_maxpage = MAXPAGE; #elif defined(MSDOS) || defined(__CYGWIN__) - real_maxpage = MAXPAGE; + real_maxpage = MAXPAGE; #elif !defined(HAVE_ULIMIT_H) - { - struct rlimit data_rlimit; + { + struct rlimit data_rlimit; # ifdef __MACH__ - sbrk(0); - getrlimit(RLIMIT_DATA, &data_rlimit); - real_maxpage = ((unsigned)get_etext() + - (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; + sbrk(0); + getrlimit(RLIMIT_DATA, &data_rlimit); + real_maxpage = ((unsigned)get_etext() + + (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; # else - extern etext; + extern etext; - getrlimit(RLIMIT_DATA, &data_rlimit); - real_maxpage = ((unsigned int)&etext + - (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; + getrlimit(RLIMIT_DATA, &data_rlimit); + real_maxpage = ((unsigned int)&etext + + (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE; # endif - if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; - } + if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; + } #else /* HAVE_ULIMIT */ - real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE; - if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; + real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE; + if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE; #endif /* USE_MMAP, MSDOS, or HAVE_ULIMIT */ #ifdef USE_MMAP - heap_start = NULL; + heap_start = NULL; #else - heap_end = sbrk(0); - i = ((cl_index)heap_end) % LISP_PAGESIZE; - if (i) - sbrk(LISP_PAGESIZE - i); - heap_end = heap_start = data_end = sbrk(0); + heap_end = sbrk(0); + i = ((cl_index)heap_end) % LISP_PAGESIZE; + if (i) + sbrk(LISP_PAGESIZE - i); + heap_end = heap_start = data_end = sbrk(0); #endif - cl_resize_hole(INIT_HOLEPAGE); - for (i = 0; i < MAXPAGE; i++) - type_map[i] = (char)t_other; + cl_resize_hole(INIT_HOLEPAGE); + for (i = 0; i < MAXPAGE; i++) + type_map[i] = (char)t_other; -/* Initialization must be done in increasing size order: */ - init_tm(t_singlefloat, "FSINGLE-FLOAT", /* 8 */ - sizeof(struct ecl_singlefloat), 1); - init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */ - init_tm(t_doublefloat, "LDOUBLE-FLOAT", /* 16 */ - sizeof(struct ecl_doublefloat), 1); - init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64); - init_tm(t_bytecodes, "bBCLOSURE", sizeof(struct ecl_bclosure), 64); - init_tm(t_base_string, "\"BASE-STRING", sizeof(struct ecl_base_string), 64); /* 20 */ +/* Initialization must be done in increasing size order: */ + init_tm(t_singlefloat, "FSINGLE-FLOAT", /* 8 */ + sizeof(struct ecl_singlefloat), 1); + init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */ + init_tm(t_doublefloat, "LDOUBLE-FLOAT", /* 16 */ + sizeof(struct ecl_doublefloat), 1); + init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64); + init_tm(t_bytecodes, "bBCLOSURE", sizeof(struct ecl_bclosure), 64); + init_tm(t_base_string, "\"BASE-STRING", sizeof(struct ecl_base_string), 64); /* 20 */ #ifdef ECL_UNICODE - init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64); + init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64); #endif - init_tm(t_array, "aARRAY", sizeof(struct ecl_array), 64); /* 24 */ - init_tm(t_pathname, "pPATHNAME", sizeof(struct ecl_pathname), 1); /* 28 */ - init_tm(t_symbol, "|SYMBOL", sizeof(struct ecl_symbol), 64); /* 32 */ - init_tm(t_package, ":PACKAGE", sizeof(struct ecl_package), 1); /* 36 */ - init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct ecl_codeblock), 1); - init_tm(t_bignum, "BBIGNUM", sizeof(struct ecl_bignum), 16); - init_tm(t_ratio, "RRATIO", sizeof(struct ecl_ratio), 1); - init_tm(t_complex, "CCOMPLEX", sizeof(struct ecl_complex), 1); - init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct ecl_hashtable), 1); - init_tm(t_vector, "vVECTOR", sizeof(struct ecl_vector), 2); - init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct ecl_vector), 1); - init_tm(t_stream, "sSTREAM", sizeof(struct ecl_stream), 1); - init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1); - init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1); - init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32); - init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32); - init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1); + init_tm(t_array, "aARRAY", sizeof(struct ecl_array), 64); /* 24 */ + init_tm(t_pathname, "pPATHNAME", sizeof(struct ecl_pathname), 1); /* 28 */ + init_tm(t_symbol, "|SYMBOL", sizeof(struct ecl_symbol), 64); /* 32 */ + init_tm(t_package, ":PACKAGE", sizeof(struct ecl_package), 1); /* 36 */ + init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct ecl_codeblock), 1); + init_tm(t_bignum, "BBIGNUM", sizeof(struct ecl_bignum), 16); + init_tm(t_ratio, "RRATIO", sizeof(struct ecl_ratio), 1); + init_tm(t_complex, "CCOMPLEX", sizeof(struct ecl_complex), 1); + init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct ecl_hashtable), 1); + init_tm(t_vector, "vVECTOR", sizeof(struct ecl_vector), 2); + init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct ecl_vector), 1); + init_tm(t_stream, "sSTREAM", sizeof(struct ecl_stream), 1); + init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1); + init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1); + init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32); + init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32); + init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1); #ifndef CLOS - init_tm(t_structure, "SSTRUCTURE", sizeof(struct ecl_structure), 32); + init_tm(t_structure, "SSTRUCTURE", sizeof(struct ecl_structure), 32); #else - init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32); + init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32); #endif /* CLOS */ - init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1); + init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1); #ifdef ECL_THREADS - init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2); - init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2); - init_tm(t_condition_variable, "tCONDITION-VARIABLE", + init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2); + init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2); + init_tm(t_condition_variable, "tCONDITION-VARIABLE", sizeof(struct ecl_condition_variable), 2); #endif /* THREADS */ #ifdef ECL_SEMAPHORES - init_tm(t_semaphore, "tSEMAPHORE", + init_tm(t_semaphore, "tSEMAPHORE", sizeof(struct ecl_semaphore), 2); #endif #ifdef ECL_LONG_FLOAT - init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2); + init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2); #endif - ncb = 0; - ncbpage = 0; - maxcbpage = 2048; + ncb = 0; + ncbpage = 0; + maxcbpage = 2048; #ifdef NEED_MALLOC - malloc_list = ECL_NIL; - ecl_register_static_root(&malloc_list); + malloc_list = ECL_NIL; + ecl_register_static_root(&malloc_list); #endif } @@ -785,104 +785,104 @@ t_from_type(cl_object type) for (t = (int)t_start ; t < (int)t_end ; t++) { struct typemanager *tm = &tm_table[t]; if (tm->tm_name && - strncmp((tm->tm_name)+1, type->base_string.self, type->base_string.fillp) == 0) + strncmp((tm->tm_name)+1, type->base_string.self, type->base_string.fillp) == 0) return(t); } FEerror("Unrecognized type", 0); } @(defun si::allocate (type qty &optional (now ECL_NIL)) - struct typemanager *tm; - cl_ptr pp; - cl_index i; + struct typemanager *tm; + cl_ptr pp; + cl_index i; @ - tm = tm_of(t_from_type(type)); - i = ecl_to_size(qty); - if (tm->tm_npage > i) i = tm->tm_npage; - tm->tm_maxpage = i; - if (now == ECL_NIL || tm->tm_maxpage <= tm->tm_npage) - @(return ECL_T) - if (available_pages() < tm->tm_maxpage - tm->tm_npage || - (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) - FEerror("Can't allocate ~D pages for ~A.", 2, type, - make_constant_base_string(tm->tm_name+1)); - for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE) - add_page_to_freelist(pp, tm); - @(return ECL_T) + tm = tm_of(t_from_type(type)); + i = ecl_to_size(qty); + if (tm->tm_npage > i) i = tm->tm_npage; + tm->tm_maxpage = i; + if (now == ECL_NIL || tm->tm_maxpage <= tm->tm_npage) + @(return ECL_T) + if (available_pages() < tm->tm_maxpage - tm->tm_npage || + (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) + FEerror("Can't allocate ~D pages for ~A.", 2, type, + make_constant_base_string(tm->tm_name+1)); + for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE) + add_page_to_freelist(pp, tm); + @(return ECL_T) @) @(defun si::maximum-allocatable-pages (type) @ - @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage)) + @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage)) @) @(defun si::allocated-pages (type) @ - @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage)) + @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage)) @) @(defun si::allocate-contiguous-pages (qty &optional (now ECL_NIL)) - cl_index i, m; - cl_ptr p; + cl_index i, m; + cl_ptr p; @ - i = ecl_to_size(qty); - if (ncbpage > i) - FEerror("Can't set the limit for contiguous blocks to ~D,~%\ + i = ecl_to_size(qty); + if (ncbpage > i) + FEerror("Can't set the limit for contiguous blocks to ~D,~%\ since ~D pages are already allocated.", - 2, qty, MAKE_FIXNUM(ncbpage)); - maxcbpage = i; - if (Null(now)) - @(return ECL_T) - m = maxcbpage - ncbpage; - if (available_pages() < m || (p = alloc_page(m)) == NULL) - FEerror("Can't allocate ~D pages for contiguous blocks.", - 1, qty); - for (i = 0; i < m; i++) - type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous; - ncbpage += m; - cl_dealloc(p, LISP_PAGESIZE*m); - @(return ECL_T) + 2, qty, MAKE_FIXNUM(ncbpage)); + maxcbpage = i; + if (Null(now)) + @(return ECL_T) + m = maxcbpage - ncbpage; + if (available_pages() < m || (p = alloc_page(m)) == NULL) + FEerror("Can't allocate ~D pages for contiguous blocks.", + 1, qty); + for (i = 0; i < m; i++) + type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous; + ncbpage += m; + cl_dealloc(p, LISP_PAGESIZE*m); + @(return ECL_T) @) @(defun si::allocated-contiguous-pages () @ - @(return MAKE_FIXNUM(ncbpage)) + @(return MAKE_FIXNUM(ncbpage)) @) @(defun si::maximum-contiguous-pages () @ - @(return MAKE_FIXNUM(maxcbpage)) + @(return MAKE_FIXNUM(maxcbpage)) @) @(defun si::get-hole-size () @ - @(return MAKE_FIXNUM(new_holepage)) + @(return MAKE_FIXNUM(new_holepage)) @) @(defun si::set-hole-size (size) - cl_index i; + cl_index i; @ - i = ecl_to_size(size); - if (i == 0 || i > available_pages() + new_holepage) - FEerror("Illegal value for the hole size.", 0); - new_holepage = i; - @(return size) + i = ecl_to_size(size); + if (i == 0 || i > available_pages() + new_holepage) + FEerror("Illegal value for the hole size.", 0); + new_holepage = i; + @(return size) @) @(defun si::ignore-maximum-pages (&optional (flag OBJNULL)) @ - if (flag == OBJNULL) - @(return (ignore_maximum_pages? ECL_T : ECL_NIL)) - ignore_maximum_pages = Null(flag); - @(return flag) + if (flag == OBJNULL) + @(return (ignore_maximum_pages? ECL_T : ECL_NIL)) + ignore_maximum_pages = Null(flag); + @(return flag) @) #ifdef NEED_MALLOC /* - UNIX malloc simulator. + UNIX malloc simulator. - Used by - getwd, popen, etc. + Used by + getwd, popen, etc. */ #undef malloc @@ -913,10 +913,10 @@ free(void *ptr) if (ptr) { for (p = &malloc_list; !ecl_endp(*p); p = &(CDR((*p)))) if ((CAR((*p)))->base_string.self == ptr) { - cl_dealloc(CAR((*p))->base_string.self, CAR((*p))->base_string.dim+1); - CAR((*p))->base_string.self = NULL; - *p = CDR((*p)); - return; + cl_dealloc(CAR((*p))->base_string.self, CAR((*p))->base_string.dim+1); + CAR((*p))->base_string.self = NULL; + *p = CDR((*p)); + return; } FEerror("free(3) error.", 0); } @@ -934,15 +934,15 @@ realloc(void *ptr, size_t size) if (CAR(x)->base_string.self == ptr) { x = CAR(x); if (x->base_string.dim >= size) { - x->base_string.fillp = size; - return(ptr); + x->base_string.fillp = size; + return(ptr); } else { - j = x->base_string.dim; - x->base_string.self = (char *)ecl_alloc(size); - x->base_string.fillp = x->base_string.dim = size; - memcpy(x->base_string.self, ptr, j); - cl_dealloc(ptr, j); - return(x->base_string.self); + j = x->base_string.dim; + x->base_string.self = (char *)ecl_alloc(size); + x->base_string.fillp = x->base_string.dim = size; + memcpy(x->base_string.self, ptr, j); + cl_dealloc(ptr, j); + return(x->base_string.self); } } FEerror("realloc(3) error.", 0); @@ -970,8 +970,8 @@ void cfree(void *ptr) */ #define ALLOC_ALIGNED(f, size, align) \ - ((align) <= 4 ? (int)(f)(size) : \ - ((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align)))) + ((align) <= 4 ? (int)(f)(size) : \ + ((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align)))) void * memalign(size_t align, size_t size) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 792347e36..3cbf23149 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -66,23 +66,23 @@ extern void GC_init_explicit_typing(void); #endif /********************************************************** - * OBJECT ALLOCATION * + * OBJECT ALLOCATION * **********************************************************/ void _ecl_set_max_heap_size(cl_index new_size) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size = new_size); - if (new_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - GC_FREE(cl_core.safety_region); - cl_core.safety_region = 0; - } - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_set_max_heap_size(cl_core.max_heap_size = new_size); + if (new_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + cl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (cl_core.safety_region) { + GC_FREE(cl_core.safety_region); + cl_core.safety_region = 0; + } + ecl_enable_interrupts_env(the_env); } static int failure; @@ -101,16 +101,16 @@ no_warnings(char *msg, GC_word arg) static void * out_of_memory(size_t requested_bytes) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); int interrupts = the_env->disable_interrupts; int method = 0; void *output; if (!interrupts) ecl_disable_interrupts_env(the_env); - /* Free the input / output buffers */ - the_env->string_pool = ECL_NIL; + /* Free the input / output buffers */ + the_env->string_pool = ECL_NIL; - /* The out of memory condition may happen in more than one thread */ + /* The out of memory condition may happen in more than one thread */ /* But then we have to ensure the error has not been solved */ #ifdef ECL_THREADS mp_get_lock_wait(cl_core.error_lock); @@ -159,7 +159,7 @@ out_of_memory(size_t requested_bytes) ecl_enable_interrupts_env(the_env); #endif switch (method) { - case 0: cl_error(1, @'ext::storage-exhausted'); + case 0: cl_error(1, @'ext::storage-exhausted'); break; case 1: cl_cerror(2, make_constant_base_string("Extend heap size"), @'ext::storage-exhausted'); @@ -212,7 +212,7 @@ ecl_object_byte_size(cl_type t) static cl_object allocate_object_atomic(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object op; ecl_disable_interrupts_env(the_env); op = GC_MALLOC_ATOMIC(type_info->size); @@ -224,7 +224,7 @@ allocate_object_atomic(register struct ecl_type_information *type_info) static cl_object allocate_object_full(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object op; ecl_disable_interrupts_env(the_env); op = GC_MALLOC(type_info->size); @@ -237,7 +237,7 @@ allocate_object_full(register struct ecl_type_information *type_info) static cl_object allocate_object_typed(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object op; ecl_disable_interrupts_env(the_env); op = GC_malloc_explicitly_typed(type_info->size, type_info->descriptor); @@ -254,34 +254,34 @@ allocate_object_own(register struct ecl_type_information *type_info) { #define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES) #define GENERAL_MALLOC(lb,k) (void *)GC_generic_malloc(lb, k) - const cl_env_ptr the_env = ecl_process_env(); - typedef void *ptr_t; - ptr_t op; - ptr_t * opp; - size_t lg, lb; - DCL_LOCK_STATE; + const cl_env_ptr the_env = ecl_process_env(); + typedef void *ptr_t; + ptr_t op; + ptr_t * opp; + size_t lg, lb; + DCL_LOCK_STATE; ecl_disable_interrupts_env(the_env); - lb = type_info->size + TYPD_EXTRA_BYTES; - if (ecl_likely(SMALL_OBJ(lb))) { - lg = GC_size_map[lb]; - opp = &(cl_object_free_list[lg]); - LOCK(); - if( (op = *opp) == 0 ) { - UNLOCK(); - op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); - if (0 == op) return 0; - lg = GC_size_map[lb]; /* May have been uninitialized. */ - } else { - *opp = obj_link(op); - obj_link(op) = 0; - GC_bytes_allocd += GRANULES_TO_BYTES(lg); - UNLOCK(); - } - } else { - op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); + lb = type_info->size + TYPD_EXTRA_BYTES; + if (ecl_likely(SMALL_OBJ(lb))) { + lg = GC_size_map[lb]; + opp = &(cl_object_free_list[lg]); + LOCK(); + if( (op = *opp) == 0 ) { + UNLOCK(); + op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); + if (0 == op) return 0; + lg = GC_size_map[lb]; /* May have been uninitialized. */ + } else { + *opp = obj_link(op); + obj_link(op) = 0; + GC_bytes_allocd += GRANULES_TO_BYTES(lg); + UNLOCK(); + } + } else { + op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind); lg = BYTES_TO_GRANULES(GC_size(op)); - } + } ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = type_info->descriptor; ((cl_object)op)->d.t = type_info->t; ecl_enable_interrupts_env(the_env); @@ -292,71 +292,71 @@ allocate_object_own(register struct ecl_type_information *type_info) #ifdef GBC_BOEHM_OWN_MARKER #define IGNORABLE_POINTER(obj) (ECL_IMMEDIATE(obj) & 2) #define GC_MARK_AND_PUSH(obj, msp, lim, src) \ - ((!IGNORABLE_POINTER(obj) && \ - (GC_word)obj >= (GC_word)GC_least_plausible_heap_addr && \ - (GC_word)obj <= (GC_word)GC_greatest_plausible_heap_addr)? \ - GC_mark_and_push(obj, msp, lim, src) : \ - msp) + ((!IGNORABLE_POINTER(obj) && \ + (GC_word)obj >= (GC_word)GC_least_plausible_heap_addr && \ + (GC_word)obj <= (GC_word)GC_greatest_plausible_heap_addr)? \ + GC_mark_and_push(obj, msp, lim, src) : \ + msp) static struct GC_ms_entry * cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl, - GC_word env) + GC_word env) { #if 1 - cl_type t = ((cl_object)addr)->d.t; - if (ecl_likely(t > t_start && t < t_end)) { - struct ecl_type_information *info = type_info + t; - GC_word d = info->descriptor; - GC_word *p; - for (p = addr; d; p++, d<<=1) { - if ((GC_signed_word)d < 0) { - GC_word aux = *p; - if ((aux & 2) || - aux <= (GC_word)GC_least_plausible_heap_addr || - aux >= (GC_word)GC_greatest_plausible_heap_addr) - continue; - msp = GC_mark_and_push((void*)aux, (void*)msp, - (void*)msl, (void*)p); - } - } - } + cl_type t = ((cl_object)addr)->d.t; + if (ecl_likely(t > t_start && t < t_end)) { + struct ecl_type_information *info = type_info + t; + GC_word d = info->descriptor; + GC_word *p; + for (p = addr; d; p++, d<<=1) { + if ((GC_signed_word)d < 0) { + GC_word aux = *p; + if ((aux & 2) || + aux <= (GC_word)GC_least_plausible_heap_addr || + aux >= (GC_word)GC_greatest_plausible_heap_addr) + continue; + msp = GC_mark_and_push((void*)aux, (void*)msp, + (void*)msl, (void*)p); + } + } + } #else -#define MAYBE_MARK2(ptr) { \ - GC_word aux = (GC_word)(ptr); \ - if (!(aux & 2) && \ - aux >= (GC_word)GC_least_plausible_heap_addr && \ - aux <= (GC_word)GC_greatest_plausible_heap_addr) \ - msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ - } -#define MAYBE_MARK(ptr) { \ - GC_word aux = (GC_word)(ptr); \ - if (!(aux & 2) && \ - aux >= (GC_word)lpa && \ - aux <= (GC_word)gpa) \ - msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ - } - cl_object o = (cl_object)addr; - const GC_word lpa = (GC_word)GC_least_plausible_heap_addr; - const GC_word gpa = (GC_word)GC_greatest_plausible_heap_addr; - switch (o->d.t) { - case t_bignum: +#define MAYBE_MARK2(ptr) { \ + GC_word aux = (GC_word)(ptr); \ + if (!(aux & 2) && \ + aux >= (GC_word)GC_least_plausible_heap_addr && \ + aux <= (GC_word)GC_greatest_plausible_heap_addr) \ + msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ + } +#define MAYBE_MARK(ptr) { \ + GC_word aux = (GC_word)(ptr); \ + if (!(aux & 2) && \ + aux >= (GC_word)lpa && \ + aux <= (GC_word)gpa) \ + msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \ + } + cl_object o = (cl_object)addr; + const GC_word lpa = (GC_word)GC_least_plausible_heap_addr; + const GC_word gpa = (GC_word)GC_greatest_plausible_heap_addr; + switch (o->d.t) { + case t_bignum: MAYBE_MARK(ECL_BIGNUN_LIMBS(o)); - break; + break; case t_ratio: MAYBE_MARK(o->ratio.num); MAYBE_MARK(o->ratio.den); - break; + break; case t_complex: MAYBE_MARK(o->complex.real); MAYBE_MARK(o->complex.imag); - break; + break; case t_symbol: MAYBE_MARK(o->symbol.hpack); MAYBE_MARK(o->symbol.name); MAYBE_MARK(o->symbol.plist); MAYBE_MARK(o->symbol.gfdef); MAYBE_MARK(o->symbol.value); - break; + break; case t_package: MAYBE_MARK(o->pack.external); MAYBE_MARK(o->pack.internal); @@ -365,23 +365,23 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->pack.shadowings); MAYBE_MARK(o->pack.nicknames); MAYBE_MARK(o->pack.name); - break; + break; case t_hashtable: MAYBE_MARK(o->hash.threshold); MAYBE_MARK(o->hash.rehash_size); MAYBE_MARK(o->hash.data); - break; - case t_array: + break; + case t_array: MAYBE_MARK(o->array.dims); case t_vector: # ifdef ECL_UNICODE case t_string: # endif - case t_base_string: + case t_base_string: case t_bitvector: MAYBE_MARK(o->vector.self.t); MAYBE_MARK(o->vector.displaced); - break; + break; case t_stream: MAYBE_MARK(o->stream.format_table); MAYBE_MARK(o->stream.format); @@ -390,16 +390,16 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->stream.object1); MAYBE_MARK(o->stream.object0); MAYBE_MARK(o->stream.ops); - break; + break; case t_random: MAYBE_MARK(o->random.value); - break; + break; case t_readtable: # ifdef ECL_UNICODE MAYBE_MARK(o->readtable.hash); # endif MAYBE_MARK(o->readtable.table); - break; + break; case t_pathname: MAYBE_MARK(o->pathname.version); MAYBE_MARK(o->pathname.type); @@ -407,7 +407,7 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->pathname.directory); MAYBE_MARK(o->pathname.device); MAYBE_MARK(o->pathname.host); - break; + break; case t_bytecodes: MAYBE_MARK(o->bytecodes.file_position); MAYBE_MARK(o->bytecodes.file); @@ -415,40 +415,40 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->bytecodes.code); MAYBE_MARK(o->bytecodes.definition); MAYBE_MARK(o->bytecodes.name); - break; + break; case t_bclosure: MAYBE_MARK(o->bclosure.lex); MAYBE_MARK(o->bclosure.code); - break; + break; case t_cfun: MAYBE_MARK(o->cfun.file_position); MAYBE_MARK(o->cfun.file); MAYBE_MARK(o->cfun.block); MAYBE_MARK(o->cfun.name); - break; + break; case t_cfunfixed: MAYBE_MARK(o->cfunfixed.file_position); MAYBE_MARK(o->cfunfixed.file); MAYBE_MARK(o->cfunfixed.block); MAYBE_MARK(o->cfunfixed.name); - break; + break; case t_cclosure: MAYBE_MARK(o->cclosure.file_position); MAYBE_MARK(o->cclosure.file); MAYBE_MARK(o->cclosure.block); MAYBE_MARK(o->cclosure.env); - break; + break; # ifndef CLOS case t_structure: MAYBE_MARK(o->structure.name); MAYBE_MARK(o->structure.self); - break; + break; # else case t_instance: MAYBE_MARK(o->instance.slots); MAYBE_MARK(o->instance.sig); MAYBE_MARK(o->instance.clas); - break; + break; # endif # ifdef ECL_THREADS case t_process: @@ -465,40 +465,40 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->process.name); if (o->process.env && o->process.env != ECL_NIL) ecl_mark_env(o->process.env); - break; + break; case t_lock: MAYBE_MARK(o->lock.queue_list); MAYBE_MARK(o->lock.queue_spinlock); MAYBE_MARK(o->lock.owner); MAYBE_MARK(o->lock.name); - break; + break; case t_condition_variable: MAYBE_MARK(o->condition_variable.queue_spinlock); MAYBE_MARK(o->condition_variable.queue_list); MAYBE_MARK(o->condition_variable.lock); - break; - case t_rwlock: - MAYBE_MARK(o->rwlock.name); + break; + case t_rwlock: + MAYBE_MARK(o->rwlock.name); # ifndef ECL_RWLOCK - MAYBE_MARK(o->rwlock.mutex); - break; + MAYBE_MARK(o->rwlock.mutex); + break; # endif case t_semaphore: MAYBE_MARK(o->semaphore.queue_list); MAYBE_MARK(o->semaphore.queue_spinlock); MAYBE_MARK(o->semaphore.name); - break; + break; case t_barrier: MAYBE_MARK(o->barrier.queue_list); MAYBE_MARK(o->barrier.queue_spinlock); MAYBE_MARK(o->barrier.name); - break; + break; case t_mailbox: MAYBE_MARK(o->mailbox.data); - MAYBE_MARK(o->mailbox.name); - MAYBE_MARK(o->mailbox.reader_semaphore); - MAYBE_MARK(o->mailbox.writer_semaphore); - break; + MAYBE_MARK(o->mailbox.name); + MAYBE_MARK(o->mailbox.reader_semaphore); + MAYBE_MARK(o->mailbox.writer_semaphore); + break; # endif case t_codeblock: MAYBE_MARK(o->cblock.error); @@ -508,27 +508,27 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl MAYBE_MARK(o->cblock.next); MAYBE_MARK(o->cblock.temp_data); MAYBE_MARK(o->cblock.data); - break; + break; case t_foreign: MAYBE_MARK(o->foreign.tag); MAYBE_MARK(o->foreign.data); - break; + break; case t_frame: MAYBE_MARK(o->frame.env); MAYBE_MARK(o->frame.base); MAYBE_MARK(o->frame.stack); - break; - default: - break; - } + break; + default: + break; + } #endif - return msp; + return msp; } static cl_object allocate_object_marked(register struct ecl_type_information *type_info) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object op; ecl_disable_interrupts_env(the_env); op = GC_generic_malloc(type_info->size, cl_object_kind); @@ -550,85 +550,85 @@ ecl_alloc_object(cl_type t) error_wrong_tag(t); return OBJNULL; #else - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); - /* GC_MALLOC already resets objects */ - switch (t) { - case t_fixnum: - return ecl_make_fixnum(0); /* Immediate fixnum */ - case t_character: - return ECL_CODE_CHAR(' '); /* Immediate character */ + /* GC_MALLOC already resets objects */ + switch (t) { + case t_fixnum: + return ecl_make_fixnum(0); /* Immediate fixnum */ + case t_character: + return ECL_CODE_CHAR(' '); /* Immediate character */ #ifdef ECL_SSE2 - case t_sse_pack: + case t_sse_pack: #endif #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_singlefloat: - case t_doublefloat: { - cl_object obj; - ecl_disable_interrupts_env(the_env); - obj = (cl_object)GC_MALLOC_ATOMIC(type_info[t].size); - ecl_enable_interrupts_env(the_env); + case t_singlefloat: + case t_doublefloat: { + cl_object obj; + ecl_disable_interrupts_env(the_env); + obj = (cl_object)GC_MALLOC_ATOMIC(type_info[t].size); + ecl_enable_interrupts_env(the_env); obj->d.t = t; return obj; - } - case t_bignum: - case t_ratio: - case t_complex: - case t_symbol: - case t_package: - case t_hashtable: - case t_array: - case t_vector: - case t_base_string: + } + case t_bignum: + case t_ratio: + case t_complex: + case t_symbol: + case t_package: + case t_hashtable: + case t_array: + case t_vector: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_bitvector: - case t_stream: - case t_random: - case t_readtable: - case t_pathname: - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: + case t_bitvector: + case t_stream: + case t_random: + case t_readtable: + case t_pathname: + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: #ifdef CLOS - case t_instance: + case t_instance: #else - case t_structure: + case t_structure: #endif #ifdef ECL_THREADS - case t_process: + case t_process: case t_lock: case t_rwlock: case t_condition_variable: case t_semaphore: case t_barrier: - case t_mailbox: + case t_mailbox: #endif - case t_foreign: - case t_codeblock: { - cl_object obj; - ecl_disable_interrupts_env(the_env); - obj = (cl_object)GC_MALLOC(type_info[t].size); - ecl_enable_interrupts_env(the_env); + case t_foreign: + case t_codeblock: { + cl_object obj; + ecl_disable_interrupts_env(the_env); + obj = (cl_object)GC_MALLOC(type_info[t].size); + ecl_enable_interrupts_env(the_env); obj->d.t = t; return obj; - } - default: - printf("\ttype = %d\n", t); - ecl_internal_error("alloc botch."); - } + } + default: + printf("\ttype = %d\n", t); + ecl_internal_error("alloc botch."); + } #endif } cl_object ecl_alloc_compact_object(cl_type t, cl_index extra_space) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_index size = type_info[t].size; cl_object x; ecl_disable_interrupts_env(the_env); @@ -642,116 +642,116 @@ ecl_alloc_compact_object(cl_type t, cl_index extra_space) cl_object ecl_cons(cl_object a, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_cons *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC(sizeof(struct ecl_cons)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); #ifdef ECL_SMALL_CONS - obj->car = a; - obj->cdr = d; - return ECL_PTR_CONS(obj); + obj->car = a; + obj->cdr = d; + return ECL_PTR_CONS(obj); #else - obj->t = t_list; - obj->car = a; - obj->cdr = d; - return (cl_object)obj; + obj->t = t_list; + obj->car = a; + obj->cdr = d; + return (cl_object)obj; #endif } cl_object ecl_list1(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_cons *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC(sizeof(struct ecl_cons)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); #ifdef ECL_SMALL_CONS - obj->car = a; - obj->cdr = ECL_NIL; - return ECL_PTR_CONS(obj); + obj->car = a; + obj->cdr = ECL_NIL; + return ECL_PTR_CONS(obj); #else - obj->t = t_list; - obj->car = a; - obj->cdr = ECL_NIL; - return (cl_object)obj; + obj->t = t_list; + obj->car = a; + obj->cdr = ECL_NIL; + return (cl_object)obj; #endif } cl_object ecl_alloc_instance(cl_index slots) { - cl_object i; - i = ecl_alloc_object(t_instance); - i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); - i->instance.length = slots; + cl_object i; + i = ecl_alloc_object(t_instance); + i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); + i->instance.length = slots; i->instance.entry = FEnot_funcallable_vararg; i->instance.sig = ECL_UNBOUND; - return i; + return i; } void * ecl_alloc_uncollectable(size_t size) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = GC_MALLOC_UNCOLLECTABLE(size); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = GC_MALLOC_UNCOLLECTABLE(size); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_free_uncollectable(void *pointer) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_FREE(pointer); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_FREE(pointer); + ecl_enable_interrupts_env(the_env); } void * ecl_alloc_unprotected(cl_index n) { - return GC_MALLOC_IGNORE_OFF_PAGE(n); + return GC_MALLOC_IGNORE_OFF_PAGE(n); } void * ecl_alloc_atomic_unprotected(cl_index n) { - return GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n); + return GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n); } void * ecl_alloc(cl_index n) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = ecl_alloc_unprotected(n); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = ecl_alloc_unprotected(n); + ecl_enable_interrupts_env(the_env); + return output; } void * ecl_alloc_atomic(cl_index n) { - const cl_env_ptr the_env = ecl_process_env(); - void *output; - ecl_disable_interrupts_env(the_env); - output = ecl_alloc_atomic_unprotected(n); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = ecl_alloc_atomic_unprotected(n); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_dealloc(void *ptr) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_FREE(ptr); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_FREE(ptr); + ecl_enable_interrupts_env(the_env); } static int alloc_initialized = FALSE; @@ -775,38 +775,38 @@ init_alloc(void) { union cl_lispunion o; struct ecl_cons c; - int i; - if (alloc_initialized) return; - alloc_initialized = TRUE; - /* - * Garbage collector restrictions: we set up the garbage collector - * library to work as follows - * - * 1) The garbage collector shall not scan shared libraries - * explicitely. - * 2) We only detect objects that are referenced by a pointer to - * the begining or to the first byte. - * 3) Out of the incremental garbage collector, we only use the - * generational component. - */ - GC_set_no_dls(1); - GC_set_all_interior_pointers(0); - GC_set_time_limit(GC_TIME_UNLIMITED); - GC_init(); + int i; + if (alloc_initialized) return; + alloc_initialized = TRUE; + /* + * Garbage collector restrictions: we set up the garbage collector + * library to work as follows + * + * 1) The garbage collector shall not scan shared libraries + * explicitely. + * 2) We only detect objects that are referenced by a pointer to + * the begining or to the first byte. + * 3) Out of the incremental garbage collector, we only use the + * generational component. + */ + GC_set_no_dls(1); + GC_set_all_interior_pointers(0); + GC_set_time_limit(GC_TIME_UNLIMITED); + GC_init(); #ifdef ECL_THREADS # if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 - GC_allow_register_threads(); + GC_allow_register_threads(); # endif #endif - if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { - GC_enable_incremental(); - } - GC_register_displacement(1); + if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { + GC_enable_incremental(); + } + GC_register_displacement(1); #ifdef GBC_BOEHM_PRECISE - GC_init_explicit_typing(); + GC_init_explicit_typing(); #endif - GC_clear_roots(); - GC_disable(); + GC_clear_roots(); + GC_disable(); #ifdef GBC_BOEHM_PRECISE # ifdef GBC_BOEHM_OWN_ALLOCATOR @@ -817,7 +817,7 @@ init_alloc(void) # else # ifdef GBC_BOEHM_OWN_MARKER cl_object_free_list = (void **)GC_new_free_list_inner(); - cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); + cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); cl_object_kind = GC_new_kind_inner(cl_object_free_list, GC_MAKE_PROC(cl_object_mark_proc_index, 0), FALSE, TRUE); @@ -825,76 +825,76 @@ init_alloc(void) # endif #endif /* !GBC_BOEHM_PRECISE */ - GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); + GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); /* Save some memory for the case we get tight. */ - if (cl_core.max_heap_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - cl_core.safety_region = 0; - } + if (cl_core.max_heap_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + cl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (cl_core.safety_region) { + cl_core.safety_region = 0; + } #define init_tm(x,y,z,w) { \ type_info[x].size = (z); \ if ((w) == 0) { type_info[x].allocator = allocate_object_atomic; } } - for (i = 0; i < t_end; i++) { + for (i = 0; i < t_end; i++) { type_info[i].t = i; - type_info[i].size = 0; + type_info[i].size = 0; type_info[i].allocator = allocate_object_full; - } - init_tm(t_list, "CONS", sizeof(struct ecl_cons), 2); - init_tm(t_bignum, "BIGNUM", sizeof(struct ecl_bignum), 2); - init_tm(t_ratio, "RATIO", sizeof(struct ecl_ratio), 2); - init_tm(t_singlefloat, "SINGLE-FLOAT", sizeof(struct ecl_singlefloat), 0); - init_tm(t_doublefloat, "DOUBLE-FLOAT", sizeof(struct ecl_doublefloat), 0); + } + init_tm(t_list, "CONS", sizeof(struct ecl_cons), 2); + init_tm(t_bignum, "BIGNUM", sizeof(struct ecl_bignum), 2); + init_tm(t_ratio, "RATIO", sizeof(struct ecl_ratio), 2); + init_tm(t_singlefloat, "SINGLE-FLOAT", sizeof(struct ecl_singlefloat), 0); + init_tm(t_doublefloat, "DOUBLE-FLOAT", sizeof(struct ecl_doublefloat), 0); #ifdef ECL_LONG_FLOAT - init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float), 0); + init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float), 0); #endif - init_tm(t_complex, "COMPLEX", sizeof(struct ecl_complex), 2); - init_tm(t_symbol, "SYMBOL", sizeof(struct ecl_symbol), 5); - init_tm(t_package, "PACKAGE", sizeof(struct ecl_package), -1); /* 36 */ + init_tm(t_complex, "COMPLEX", sizeof(struct ecl_complex), 2); + init_tm(t_symbol, "SYMBOL", sizeof(struct ecl_symbol), 5); + init_tm(t_package, "PACKAGE", sizeof(struct ecl_package), -1); /* 36 */ #ifdef ECL_THREADS - init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 3); + init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 3); #else - init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 4); + init_tm(t_hashtable, "HASH-TABLE", sizeof(struct ecl_hashtable), 4); #endif - init_tm(t_array, "ARRAY", sizeof(struct ecl_array), 3); - init_tm(t_vector, "VECTOR", sizeof(struct ecl_vector), 2); + init_tm(t_array, "ARRAY", sizeof(struct ecl_array), 3); + init_tm(t_vector, "VECTOR", sizeof(struct ecl_vector), 2); #ifdef ECL_UNICODE - init_tm(t_string, "STRING", sizeof(struct ecl_string), 2); + init_tm(t_string, "STRING", sizeof(struct ecl_string), 2); #endif - init_tm(t_base_string, "BASE-STRING", sizeof(struct ecl_base_string), 2); - init_tm(t_bitvector, "BIT-VECTOR", sizeof(struct ecl_vector), 2); - init_tm(t_stream, "STREAM", sizeof(struct ecl_stream), 6); - init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random), -1); - init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable), 2); - init_tm(t_pathname, "PATHNAME", sizeof(struct ecl_pathname), -1); - init_tm(t_bytecodes, "BYTECODES", sizeof(struct ecl_bytecodes), -1); - init_tm(t_bclosure, "BCLOSURE", sizeof(struct ecl_bclosure), 3); - init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun), -1); - init_tm(t_cfunfixed, "CFUNFIXED", sizeof(struct ecl_cfunfixed), -1); - init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure), -1); + init_tm(t_base_string, "BASE-STRING", sizeof(struct ecl_base_string), 2); + init_tm(t_bitvector, "BIT-VECTOR", sizeof(struct ecl_vector), 2); + init_tm(t_stream, "STREAM", sizeof(struct ecl_stream), 6); + init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random), -1); + init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable), 2); + init_tm(t_pathname, "PATHNAME", sizeof(struct ecl_pathname), -1); + init_tm(t_bytecodes, "BYTECODES", sizeof(struct ecl_bytecodes), -1); + init_tm(t_bclosure, "BCLOSURE", sizeof(struct ecl_bclosure), 3); + init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun), -1); + init_tm(t_cfunfixed, "CFUNFIXED", sizeof(struct ecl_cfunfixed), -1); + init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure), -1); #ifndef CLOS - init_tm(t_structure, "STRUCTURE", sizeof(struct ecl_structure), 2); + init_tm(t_structure, "STRUCTURE", sizeof(struct ecl_structure), 2); #else - init_tm(t_instance, "INSTANCE", sizeof(struct ecl_instance), 4); + init_tm(t_instance, "INSTANCE", sizeof(struct ecl_instance), 4); #endif /* CLOS */ #ifdef ECL_THREADS - init_tm(t_process, "PROCESS", sizeof(struct ecl_process), 8); - init_tm(t_lock, "LOCK", sizeof(struct ecl_lock), 2); - init_tm(t_rwlock, "LOCK", sizeof(struct ecl_rwlock), 0); - init_tm(t_condition_variable, "CONDITION-VARIABLE", + init_tm(t_process, "PROCESS", sizeof(struct ecl_process), 8); + init_tm(t_lock, "LOCK", sizeof(struct ecl_lock), 2); + init_tm(t_rwlock, "LOCK", sizeof(struct ecl_rwlock), 0); + init_tm(t_condition_variable, "CONDITION-VARIABLE", sizeof(struct ecl_condition_variable), 0); - init_tm(t_semaphore, "SEMAPHORES", sizeof(struct ecl_semaphore), 0); - init_tm(t_barrier, "BARRIER", sizeof(struct ecl_barrier), 0); - init_tm(t_mailbox, "MAILBOX", sizeof(struct ecl_mailbox), 0); + init_tm(t_semaphore, "SEMAPHORES", sizeof(struct ecl_semaphore), 0); + init_tm(t_barrier, "BARRIER", sizeof(struct ecl_barrier), 0); + init_tm(t_mailbox, "MAILBOX", sizeof(struct ecl_mailbox), 0); #endif - init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); - init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); - init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 2); - init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); + init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); + init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); + init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 2); + init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 - init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); + init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); #endif #ifdef GBC_BOEHM_PRECISE type_info[t_list].descriptor = @@ -943,7 +943,7 @@ init_alloc(void) to_bitmap(&o, &(o.string.self)) | to_bitmap(&o, &(o.string.displaced)); # endif - type_info[t_base_string].descriptor = + type_info[t_base_string].descriptor = to_bitmap(&o, &(o.base_string.self)) | to_bitmap(&o, &(o.base_string.displaced)); type_info[t_bitvector].descriptor = @@ -1033,23 +1033,23 @@ init_alloc(void) to_bitmap(&o, &(o.rwlock.name)) | to_bitmap(&o, &(o.rwlock.mutex)); # endif - type_info[t_condition_variable].descriptor = - to_bitmap(&o, &(o.condition_variable.lock)) | - to_bitmap(&o, &(o.condition_variable.queue_list)) | - to_bitmap(&o, &(o.condition_variable.queue_spinlock)); - type_info[t_semaphore].descriptor = - to_bitmap(&o, &(o.semaphore.name)) | - to_bitmap(&o, &(o.semaphore.queue_list)) | - to_bitmap(&o, &(o.semaphore.queue_spinlock)); - type_info[t_barrier].descriptor = - to_bitmap(&o, &(o.barrier.name)) | - to_bitmap(&o, &(o.barrier.queue_list)) | - to_bitmap(&o, &(o.barrier.queue_spinlock)); - type_info[t_mailbox].descriptor = - to_bitmap(&o, &(o.mailbox.name)) | - to_bitmap(&o, &(o.mailbox.data)) | - to_bitmap(&o, &(o.mailbox.reader_semaphore)) | - to_bitmap(&o, &(o.mailbox.writer_semaphore)); + type_info[t_condition_variable].descriptor = + to_bitmap(&o, &(o.condition_variable.lock)) | + to_bitmap(&o, &(o.condition_variable.queue_list)) | + to_bitmap(&o, &(o.condition_variable.queue_spinlock)); + type_info[t_semaphore].descriptor = + to_bitmap(&o, &(o.semaphore.name)) | + to_bitmap(&o, &(o.semaphore.queue_list)) | + to_bitmap(&o, &(o.semaphore.queue_spinlock)); + type_info[t_barrier].descriptor = + to_bitmap(&o, &(o.barrier.name)) | + to_bitmap(&o, &(o.barrier.queue_list)) | + to_bitmap(&o, &(o.barrier.queue_spinlock)); + type_info[t_mailbox].descriptor = + to_bitmap(&o, &(o.mailbox.name)) | + to_bitmap(&o, &(o.mailbox.data)) | + to_bitmap(&o, &(o.mailbox.reader_semaphore)) | + to_bitmap(&o, &(o.mailbox.writer_semaphore)); # endif type_info[t_codeblock].descriptor = to_bitmap(&o, &(o.cblock.data)) | @@ -1058,7 +1058,7 @@ init_alloc(void) to_bitmap(&o, &(o.cblock.name)) | to_bitmap(&o, &(o.cblock.links)) | to_bitmap(&o, &(o.cblock.source)) | - to_bitmap(&o, &(o.cblock.error)); + to_bitmap(&o, &(o.cblock.error)); type_info[t_foreign].descriptor = to_bitmap(&o, &(o.foreign.data)) | to_bitmap(&o, &(o.foreign.tag)); @@ -1066,18 +1066,18 @@ init_alloc(void) to_bitmap(&o, &(o.frame.stack)) | to_bitmap(&o, &(o.frame.base)) | to_bitmap(&o, &(o.frame.env)); - type_info[t_weak_pointer].descriptor = 0; + type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 - type_info[t_sse_pack].descriptor = 0; + type_info[t_sse_pack].descriptor = 0; #endif - for (i = 0; i < t_end; i++) { + for (i = 0; i < t_end; i++) { GC_word descriptor = type_info[i].descriptor; int bits = type_info[i].size / sizeof(GC_word); if (descriptor) { #ifdef GBC_BOEHM_OWN_MARKER - type_info[i].allocator = allocate_object_marked; + type_info[i].allocator = allocate_object_marked; descriptor = GC_make_descriptor(&descriptor, bits); - descriptor &= ~GC_DS_TAGS; + descriptor &= ~GC_DS_TAGS; #else GC_word mask = (1 << (bits-1)) - 1; mask ^= (descriptor >> 1); @@ -1092,119 +1092,119 @@ init_alloc(void) descriptor = 0; } type_info[i].descriptor = descriptor; - } + } #endif /* GBC_BOEHM_PRECISE */ - old_GC_push_other_roots = GC_push_other_roots; - GC_push_other_roots = stacks_scanner; + old_GC_push_other_roots = GC_push_other_roots; + GC_push_other_roots = stacks_scanner; #ifdef HAVE_GC_SET_START_CALLBACK - GC_old_start_callback = GC_get_start_callback(); - GC_set_start_callback(gather_statistics); + GC_old_start_callback = GC_get_start_callback(); + GC_set_start_callback(gather_statistics); #else - GC_old_start_callback = GC_start_call_back; - GC_start_call_back = (void (*)(void))gather_statistics; + GC_old_start_callback = GC_start_call_back; + GC_start_call_back = (void (*)(void))gather_statistics; #endif - GC_set_java_finalization(1); + GC_set_java_finalization(1); GC_set_oom_fn(out_of_memory); GC_set_warn_proc(no_warnings); - GC_enable(); + GC_enable(); } /********************************************************** - * FINALIZATION * + * FINALIZATION * **********************************************************/ static void standard_finalizer(cl_object o) { - switch (o->d.t) { + switch (o->d.t) { #ifdef ENABLE_DLOPEN - case t_codeblock: - ecl_library_close(o); - break; + case t_codeblock: + ecl_library_close(o); + break; #endif - case t_stream: - cl_close(1, o); - break; - case t_weak_pointer: - GC_unregister_disappearing_link((void**)&(o->weak.value)); - break; + case t_stream: + cl_close(1, o); + break; + case t_weak_pointer: + GC_unregister_disappearing_link((void**)&(o->weak.value)); + break; #ifdef ECL_THREADS # ifdef ECL_RWLOCK - case t_rwlock: { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - pthread_rwlock_destroy(&o->rwlock.mutex); - ecl_enable_interrupts_env(the_env); - break; - } + case t_rwlock: { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + pthread_rwlock_destroy(&o->rwlock.mutex); + ecl_enable_interrupts_env(the_env); + break; + } # endif case t_symbol: { - ecl_atomic_push(&cl_core.reused_indices, - ecl_make_fixnum(o->symbol.binding)); + ecl_atomic_push(&cl_core.reused_indices, + ecl_make_fixnum(o->symbol.binding)); } #endif /* ECL_THREADS */ - default:; - } + default:; + } } static void wrapped_finalizer(cl_object o, cl_object finalizer) { - if (finalizer != ECL_NIL && finalizer != NULL) { + if (finalizer != ECL_NIL && finalizer != NULL) { CL_NEWENV_BEGIN { if (finalizer != ECL_T) { - funcall(2, finalizer, o); + funcall(2, finalizer, o); } standard_finalizer(o); } CL_NEWENV_END; - } + } } cl_object si_get_finalizer(cl_object o) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object output; - GC_finalization_proc ofn; - void *odata; - ecl_disable_interrupts_env(the_env); - GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); - if (ofn == 0) { - output = ECL_NIL; - } else if (ofn == (GC_finalization_proc)wrapped_finalizer) { - output = (cl_object)odata; - } else { - output = ECL_NIL; - } - GC_register_finalizer_no_order(o, ofn, odata, &ofn, &odata); - ecl_enable_interrupts_env(the_env); - @(return output) + const cl_env_ptr the_env = ecl_process_env(); + cl_object output; + GC_finalization_proc ofn; + void *odata; + ecl_disable_interrupts_env(the_env); + GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); + if (ofn == 0) { + output = ECL_NIL; + } else if (ofn == (GC_finalization_proc)wrapped_finalizer) { + output = (cl_object)odata; + } else { + output = ECL_NIL; + } + GC_register_finalizer_no_order(o, ofn, odata, &ofn, &odata); + ecl_enable_interrupts_env(the_env); + @(return output) } void ecl_set_finalizer_unprotected(cl_object o, cl_object finalizer) { - GC_finalization_proc ofn; - void *odata; - if (finalizer == ECL_NIL) { - GC_register_finalizer_no_order(o, (GC_finalization_proc)0, - 0, &ofn, &odata); - } else { - GC_finalization_proc newfn; - newfn = (GC_finalization_proc)wrapped_finalizer; - GC_register_finalizer_no_order(o, newfn, finalizer, - &ofn, &odata); - } + GC_finalization_proc ofn; + void *odata; + if (finalizer == ECL_NIL) { + GC_register_finalizer_no_order(o, (GC_finalization_proc)0, + 0, &ofn, &odata); + } else { + GC_finalization_proc newfn; + newfn = (GC_finalization_proc)wrapped_finalizer; + GC_register_finalizer_no_order(o, newfn, finalizer, + &ofn, &odata); + } } cl_object si_set_finalizer(cl_object o, cl_object finalizer) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); ecl_set_finalizer_unprotected(o, finalizer); - ecl_enable_interrupts_env(the_env); - @(return) + ecl_enable_interrupts_env(the_env); + @(return) } /* If we do not build our own version of the library, we do not have @@ -1219,7 +1219,7 @@ static int GC_print_stats; cl_object si_gc_stats(cl_object enable) { - cl_object old_status; + cl_object old_status; cl_object size1 = ecl_make_fixnum(0); cl_object size2 = ecl_make_fixnum(0); if (cl_core.gc_stats == 0) { @@ -1229,12 +1229,12 @@ si_gc_stats(cl_object enable) } else { old_status = ECL_T; } - if (cl_core.bytes_consed == ECL_NIL) { - cl_core.bytes_consed = ecl_alloc_object(t_bignum); - mpz_init2(cl_core.bytes_consed->big.big_num, 128); - cl_core.gc_counter = ecl_alloc_object(t_bignum); - mpz_init2(cl_core.gc_counter->big.big_num, 128); - } else { + if (cl_core.bytes_consed == ECL_NIL) { + cl_core.bytes_consed = ecl_alloc_object(t_bignum); + mpz_init2(cl_core.bytes_consed->big.big_num, 128); + cl_core.gc_counter = ecl_alloc_object(t_bignum); + mpz_init2(cl_core.gc_counter->big.big_num, 128); + } else { /* We need fresh copies of the bignums */ size1 = _ecl_big_plus_fix(cl_core.bytes_consed, 1); size2 = _ecl_big_plus_fix(cl_core.gc_counter, 1); @@ -1249,7 +1249,7 @@ si_gc_stats(cl_object enable) cl_core.gc_stats = 1; GC_print_stats = (enable == @':full'); } - @(return size1 size2 old_status) + @(return size1 size2 old_status) } /* @@ -1260,139 +1260,139 @@ si_gc_stats(cl_object enable) static void gather_statistics() { - if (cl_core.gc_stats) { - /* Sorry, no gc stats if you do not use bignums */ + if (cl_core.gc_stats) { + /* Sorry, no gc stats if you do not use bignums */ #if GBC_BOEHM == 0 - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - GC_get_bytes_since_gc()); + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + GC_get_bytes_since_gc()); #else - /* This is not accurate and may wrap around. We try - to detect this assuming that an overflow in an - unsigned integer will produce an smaller - integer.*/ - static cl_index bytes = 0; - cl_index new_bytes = GC_get_total_bytes(); - if (bytes > new_bytes) { - cl_index wrapped; - wrapped = ~((cl_index)0) - bytes; - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - wrapped); - bytes = new_bytes; - } - mpz_add_ui(cl_core.bytes_consed->big.big_num, - cl_core.bytes_consed->big.big_num, - new_bytes - bytes); + /* This is not accurate and may wrap around. We try + to detect this assuming that an overflow in an + unsigned integer will produce an smaller + integer.*/ + static cl_index bytes = 0; + cl_index new_bytes = GC_get_total_bytes(); + if (bytes > new_bytes) { + cl_index wrapped; + wrapped = ~((cl_index)0) - bytes; + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + wrapped); + bytes = new_bytes; + } + mpz_add_ui(cl_core.bytes_consed->big.big_num, + cl_core.bytes_consed->big.big_num, + new_bytes - bytes); #endif - mpz_add_ui(cl_core.gc_counter->big.big_num, - cl_core.gc_counter->big.big_num, - 1); - } - if (GC_old_start_callback) - GC_old_start_callback(); + mpz_add_ui(cl_core.gc_counter->big.big_num, + cl_core.gc_counter->big.big_num, + 1); + } + if (GC_old_start_callback) + GC_old_start_callback(); } /********************************************************** - * GARBAGE COLLECTOR * + * GARBAGE COLLECTOR * **********************************************************/ static void ecl_mark_env(struct cl_env_struct *env) { #if 1 - if (env->stack) { - GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); - GC_set_mark_bit((void *)env->stack); - } - if (env->frs_top) { - GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); - GC_set_mark_bit((void *)env->frs_org); - } - if (env->bds_top) { - GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); - GC_set_mark_bit((void *)env->bds_org); - } + if (env->stack) { + GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); + GC_set_mark_bit((void *)env->stack); + } + if (env->frs_top) { + GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); + GC_set_mark_bit((void *)env->frs_org); + } + if (env->bds_top) { + GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); + GC_set_mark_bit((void *)env->bds_org); + } #endif - /*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/ + /*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/ #if defined(ECL_THREADS) && !defined(ECL_USE_MPROTECT) && !defined(ECL_USE_GUARD_PAGE) - /* When using threads, "env" is a pointer to memory allocated by ECL. */ - GC_push_conditional((void *)env, (void *)(env + 1), 1); - GC_set_mark_bit((void *)env); + /* When using threads, "env" is a pointer to memory allocated by ECL. */ + GC_push_conditional((void *)env, (void *)(env + 1), 1); + GC_set_mark_bit((void *)env); #else - /* When not using threads, "env" is mmaped or statically allocated. */ - GC_push_all((void *)env, (void *)(env + 1)); + /* When not using threads, "env" is mmaped or statically allocated. */ + GC_push_all((void *)env, (void *)(env + 1)); #endif } static void stacks_scanner() { - cl_env_ptr the_env = ecl_process_env(); - cl_object l; - l = cl_core.libraries; - if (l) { - for (; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object dll = ECL_CONS_CAR(l); - if (dll->cblock.locked) { - GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1); - GC_set_mark_bit((void *)dll); - } - } - } - GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); - GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); - if (the_env != NULL) - ecl_mark_env(the_env); + cl_env_ptr the_env = ecl_process_env(); + cl_object l; + l = cl_core.libraries; + if (l) { + for (; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object dll = ECL_CONS_CAR(l); + if (dll->cblock.locked) { + GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1); + GC_set_mark_bit((void *)dll); + } + } + } + GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); + GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); + if (the_env != NULL) + ecl_mark_env(the_env); #ifdef ECL_THREADS - l = cl_core.processes; - if (l != OBJNULL) { - cl_index i, size; - for (i = 0, size = l->vector.dim; i < size; i++) { - cl_object process = l->vector.self.t[i]; - if (!Null(process)) { - cl_env_ptr env = process->process.env; - if (env && (env != the_env)) ecl_mark_env(env); - } - } - } + l = cl_core.processes; + if (l != OBJNULL) { + cl_index i, size; + for (i = 0, size = l->vector.dim; i < size; i++) { + cl_object process = l->vector.self.t[i]; + if (!Null(process)) { + cl_env_ptr env = process->process.env; + if (env && (env != the_env)) ecl_mark_env(env); + } + } + } #endif - if (old_GC_push_other_roots) - (*old_GC_push_other_roots)(); + if (old_GC_push_other_roots) + (*old_GC_push_other_roots)(); } /********************************************************** - * GARBAGE COLLECTION * + * GARBAGE COLLECTION * **********************************************************/ void ecl_register_root(cl_object *p) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_add_roots((char*)p, (char*)(p+1)); - ecl_enable_interrupts_env(the_env); + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_add_roots((char*)p, (char*)(p+1)); + ecl_enable_interrupts_env(the_env); } cl_object si_gc(cl_narg narg, ...) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_gcollect(); - ecl_enable_interrupts_env(the_env); - @(return) + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_gcollect(); + ecl_enable_interrupts_env(the_env); + @(return) } cl_object si_gc_dump() { - const cl_env_ptr the_env = ecl_process_env(); - ecl_disable_interrupts_env(the_env); - GC_dump(); - ecl_enable_interrupts_env(the_env); - @(return) + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_dump(); + ecl_enable_interrupts_env(the_env); + @(return) } /********************************************************************** @@ -1402,42 +1402,42 @@ si_gc_dump() static cl_object ecl_alloc_weak_pointer(cl_object o) { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_weak_pointer *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); - ecl_enable_interrupts_env(the_env); - obj->t = t_weak_pointer; - obj->value = o; + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_weak_pointer *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); + ecl_enable_interrupts_env(the_env); + obj->t = t_weak_pointer; + obj->value = o; if (!ECL_FIXNUMP(o) && !ECL_CHARACTERP(o) && !Null(o)) { GC_general_register_disappearing_link((void**)&(obj->value), (void*)o); si_set_finalizer((cl_object)obj, ECL_T); } - return (cl_object)obj; + return (cl_object)obj; } cl_object si_make_weak_pointer(cl_object o) { - cl_object pointer = ecl_alloc_weak_pointer(o); - @(return pointer); + cl_object pointer = ecl_alloc_weak_pointer(o); + @(return pointer); } static cl_object ecl_weak_pointer_value(cl_object o) { - return o->weak.value; + return o->weak.value; } cl_object si_weak_pointer_value(cl_object o) { - cl_object value; - if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) - FEwrong_type_only_arg(@[ext::weak-pointer-value], o, + cl_object value; + if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) + FEwrong_type_only_arg(@[ext::weak-pointer-value], o, @[ext::weak-pointer]); - value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); - @(return (value? value : ECL_NIL)); + value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); + @(return (value? value : ECL_NIL)); } #endif /* GBC_BOEHM */ diff --git a/src/c/apply.d b/src/c/apply.d index 1dd21511a..20bdfcdac 100644 --- a/src/c/apply.d +++ b/src/c/apply.d @@ -32,313 +32,313 @@ APPLY(cl_narg n, cl_objectfn fn, cl_object *x) case 7: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6]); case 8: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); case 9: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8]); + x[8]); case 10: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9]); + x[8],x[9]); case 11: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10]); + x[8],x[9],x[10]); case 12: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11]); + x[8],x[9],x[10],x[11]); case 13: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12]); + x[8],x[9],x[10],x[11],x[12]); case 14: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13]); + x[8],x[9],x[10],x[11],x[12],x[13]); case 15: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14]); case 16: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15]); case 17: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16]); case 18: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17]); case 19: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18]); case 20: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19]); case 21: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20]); case 22: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21]); case 23: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22]); case 24: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23]); case 25: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24]); case 26: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25]); case 27: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26]); case 28: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27]); case 29: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28]); case 30: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29]); case 31: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30]); case 32: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31]); case 33: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32]); case 34: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33]); case 35: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34]); case 36: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35]); case 37: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36]); case 38: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37]); case 39: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38]); case 40: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39]); case 41: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40]); case 42: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41]); case 43: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42]); case 44: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43]); case 45: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44]); case 46: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45]); case 47: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46]); case 48: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47]); case 49: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48]); case 50: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49]); case 51: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50]); case 52: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51]); case 53: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52]); case 54: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53]); case 55: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54]); case 56: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55]); case 57: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56]); case 58: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57]); case 59: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58]); case 60: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59]); case 61: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60]); case 62: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61]); case 63: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62]); default: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62],x[63]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62],x[63]); /* Arguments above 64 have been pushed on the stack */ } } @@ -357,315 +357,315 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) case 7: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6]); case 8: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); case 9: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8]); + x[8]); case 10: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9]); + x[8],x[9]); case 11: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10]); + x[8],x[9],x[10]); case 12: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11]); + x[8],x[9],x[10],x[11]); case 13: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12]); + x[8],x[9],x[10],x[11],x[12]); case 14: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13]); + x[8],x[9],x[10],x[11],x[12],x[13]); case 15: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14]); case 16: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15]); case 17: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16]); case 18: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17]); case 19: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18]); case 20: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19]); case 21: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20]); case 22: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21]); case 23: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22]); case 24: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23]); case 25: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24]); case 26: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25]); case 27: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26]); case 28: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27]); case 29: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28]); case 30: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29]); case 31: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30]); case 32: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31]); case 33: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32]); case 34: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33]); case 35: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34]); case 36: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35]); case 37: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36]); case 38: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37]); case 39: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38]); case 40: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39]); case 41: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40]); case 42: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41]); case 43: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42]); case 44: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43]); case 45: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44]); case 46: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45]); case 47: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46]); case 48: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47]); case 49: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48]); case 50: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49]); case 51: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50]); case 52: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51]); case 53: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52]); case 54: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53]); case 55: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54]); case 56: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55]); case 57: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56]); case 58: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57]); case 59: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58]); case 60: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59]); case 61: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60]); case 62: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61]); case 63: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62]); case 64: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], - x[8],x[9],x[10],x[11],x[12],x[13],x[14], - x[15],x[16],x[17],x[18],x[19],x[20],x[21], - x[22],x[23],x[24],x[25],x[26],x[27],x[28], - x[29],x[30],x[31],x[32],x[33],x[34],x[35], - x[36],x[37],x[38],x[39],x[40],x[41],x[42], - x[43],x[44],x[45],x[46],x[47],x[48],x[49], - x[50],x[51],x[52],x[53],x[54],x[55],x[56], - x[57],x[58],x[59],x[60],x[61],x[62],x[63]); + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62],x[63]); default: - FEprogram_error_noreturn("Too many arguments", 0); + FEprogram_error_noreturn("Too many arguments", 0); } } #endif diff --git a/src/c/arch/apply_x86.d b/src/c/arch/apply_x86.d index 0b3f15326..6a1ba6725 100644 --- a/src/c/arch/apply_x86.d +++ b/src/c/arch/apply_x86.d @@ -19,89 +19,89 @@ cl_object APPLY(cl_narg n, cl_objectfn fn, cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" - "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ - "jle FOO1\n\t" - "movl $63, %%ecx\n\t" -"FOO1:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal -4(%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ - "negl %%ecx\n\t" - "leal 4(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[4] on */ - "rep\n\t" + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" + "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ + "jle FOO1\n\t" + "movl $63, %%ecx\n\t" +"FOO1:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal -4(%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ + "negl %%ecx\n\t" + "leal 4(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[4] on */ + "rep\n\t" "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); - return output; + return output; } cl_object APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" /* Copy at most 63 arguments onto the stack */ - "cmpl $63, %%ecx\n\t" - "jle FOO2\n\t" - "movl $63, %%ecx\n" -"FOO2:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal (%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "negl %%ecx\n\t" - "movl %%esp, %%edi\n\t" /* then the arguments are copied from ESP[0] on */ - "rep\n\t" + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" /* Copy at most 63 arguments onto the stack */ + "cmpl $63, %%ecx\n\t" + "jle FOO2\n\t" + "movl $63, %%ecx\n" +"FOO2:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal (%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "negl %%ecx\n\t" + "movl %%esp, %%edi\n\t" /* then the arguments are copied from ESP[0] on */ + "rep\n\t" "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi"); - return output; + return output; } cl_object APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x) { - cl_object output; - asm volatile ( - "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ - "pushl %%edx\n\t" - "pushl %%ebp\n\t" - "movl %%ecx, %%edx\n\t" - "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ - "jle FOO3\n\t" - "movl $63, %%ecx\n\t" -"FOO3:\n\t" /* Here we compute the new address of the stack pointer */ - "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */ - "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ - "leal -8(%%esp,%%ecx,4), %%esp\n\t" - "andl $-16, %%esp\n\t" - "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ - "movl %%edi, 4(%%esp)\n\t" /* ESP[4] is the closure environment */ - "negl %%ecx\n\t" - "leal 8(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[8] on */ - "rep\n\t" + cl_object output; + asm volatile ( + "movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */ + "pushl %%edx\n\t" + "pushl %%ebp\n\t" + "movl %%ecx, %%edx\n\t" + "cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */ + "jle FOO3\n\t" + "movl $63, %%ecx\n\t" +"FOO3:\n\t" /* Here we compute the new address of the stack pointer */ + "movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */ + "negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */ + "leal -8(%%esp,%%ecx,4), %%esp\n\t" + "andl $-16, %%esp\n\t" + "movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */ + "movl %%edi, 4(%%esp)\n\t" /* ESP[4] is the closure environment */ + "negl %%ecx\n\t" + "leal 8(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[8] on */ + "rep\n\t" "movsl\n\t" - "call *%%eax\n\t" /* At this point the stack must be aligned */ - "movl %%ebp, %%esp\n\t" - "popl %%ebp\n\t" - "popl %%edx\n\t" + "call *%%eax\n\t" /* At this point the stack must be aligned */ + "movl %%ebp, %%esp\n\t" + "popl %%ebp\n\t" + "popl %%edx\n\t" : "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx"); - return output; + return output; } diff --git a/src/c/arch/ffi_ppc32.d b/src/c/arch/ffi_ppc32.d index 412436700..175aa1eca 100644 --- a/src/c/arch/ffi_ppc32.d +++ b/src/c/arch/ffi_ppc32.d @@ -53,69 +53,69 @@ #define MAX_FP_REGISTERS 13 struct ecl_fficall_reg { - long int registers[MAX_INT_REGISTERS]; - int int_registers_size; - double fp_registers[MAX_FP_REGISTERS]; - int fp_registers_size; + long int registers[MAX_INT_REGISTERS]; + int int_registers_size; + double fp_registers[MAX_FP_REGISTERS]; + int fp_registers_size; }; struct ecl_fficall_reg * ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) { - if (registers == 0) { - registers = (struct ecl_fficall_reg *)cl_alloc_atomic(sizeof(*registers)); - } - registers->int_registers_size = 0; - registers->fp_registers_size = 0; + if (registers == 0) { + registers = (struct ecl_fficall_reg *)cl_alloc_atomic(sizeof(*registers)); + } + registers->int_registers_size = 0; + registers->fp_registers_size = 0; } void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) { - long i; - struct ecl_fficall *fficall = cl_env.fficall; - struct ecl_fficall_reg *registers = cl_env.fficall->registers; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; - case ECL_FFI_BYTE: i = data->b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; - case ECL_FFI_SHORT: i = data->s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; - case ECL_FFI_INT: i = data->i; goto INT; - case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->l; - INT: - if (registers->int_registers_size < MAX_INT_REGISTERS) { - registers->registers[registers->int_registers_size++] = i; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&i, sizeof(long)); - break; - case ECL_FFI_DOUBLE: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->d; - registers->int_registers_size += 2; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->d, sizeof(double), sizeof(long)); - break; - case ECL_FFI_FLOAT: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->f; - registers->int_registers_size++; - } - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->f, sizeof(float), sizeof(long)); - break; - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } + long i; + struct ecl_fficall *fficall = cl_env.fficall; + struct ecl_fficall_reg *registers = cl_env.fficall->registers; + switch (type) { + case ECL_FFI_CHAR: i = data->c; goto INT; + case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; + case ECL_FFI_BYTE: i = data->b; goto INT; + case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; + case ECL_FFI_SHORT: i = data->s; goto INT; + case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; + case ECL_FFI_INT: i = data->i; goto INT; + case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; + case ECL_FFI_LONG: + case ECL_FFI_UNSIGNED_LONG: + case ECL_FFI_POINTER_VOID: + case ECL_FFI_CSTRING: + case ECL_FFI_OBJECT: + i = data->l; + INT: + if (registers->int_registers_size < MAX_INT_REGISTERS) { + registers->registers[registers->int_registers_size++] = i; + } + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&i, sizeof(long)); + break; + case ECL_FFI_DOUBLE: + if (registers->fp_registers_size < MAX_FP_REGISTERS) { + registers->fp_registers[registers->fp_registers_size++] = data->d; + registers->int_registers_size += 2; + } + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&data->d, sizeof(double), sizeof(long)); + break; + case ECL_FFI_FLOAT: + if (registers->fp_registers_size < MAX_FP_REGISTERS) { + registers->fp_registers[registers->fp_registers_size++] = data->f; + registers->int_registers_size++; + } + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&data->f, sizeof(float), sizeof(long)); + break; + case ECL_FFI_VOID: + FEerror("VOID is not a valid argument type for a C function", 0); + } } static void @@ -126,88 +126,88 @@ ecl_fficall_do_execute(cl_index buf_size, void *stack, void *gpr, void *gpfr, vo void ecl_fficall_execute(void *_f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) { - struct ecl_fficall_reg *registers = fficall->registers; - long bufsize = fficall->buffer_size; - char* buf = fficall->buffer; + struct ecl_fficall_reg *registers = fficall->registers; + long bufsize = fficall->buffer_size; + char* buf = fficall->buffer; - asm volatile ( - "mr r5,%[bufsize]\n\t" /* r5 = size of stack */ - "mr r6,%[buf]\n\t" /* r6 = origin of stack data */ - "mr r17,%[registers]\n\t" /* r17 = origin of integer registers */ - "mr r16,%[fp_registers]\n\t"/* r16 = origin of fp registers */ - "mr r15,%[fptr]\n\t" /* r15 = _f_ptr */ - "mr r29, r1\n\t" /* r29 saves r1 */ + asm volatile ( + "mr r5,%[bufsize]\n\t" /* r5 = size of stack */ + "mr r6,%[buf]\n\t" /* r6 = origin of stack data */ + "mr r17,%[registers]\n\t" /* r17 = origin of integer registers */ + "mr r16,%[fp_registers]\n\t"/* r16 = origin of fp registers */ + "mr r15,%[fptr]\n\t" /* r15 = _f_ptr */ + "mr r29, r1\n\t" /* r29 saves r1 */ - "subf r13,r5,r1\n\t" - "stwu r13,-80(r13)\n\t" /* r13 <- r1 - r5 - 80 */ - "mflr r0\n\t" - "stw r0,8(r1)\n\t" - "mr r1,r13\n\t" /* r1 <- r13 */ + "subf r13,r5,r1\n\t" + "stwu r13,-80(r13)\n\t" /* r13 <- r1 - r5 - 80 */ + "mflr r0\n\t" + "stw r0,8(r1)\n\t" + "mr r1,r13\n\t" /* r1 <- r13 */ - "stwu r14,24(r1)\n\t" /* r14 <- begin of parameters */ - "cmpwi cr0,r5,0\n\t" /* copy r5 bytes from (r6) to (r14) */ - "ble cr0,L3\n\t" - "mtctr r5\n" -"LX: lbz r0,0(r6)\n\t" - "addi r6,r6,1\n\t" - "stb r0,0(r14)\n\t" - "addi r14,r14,1\n" -"L3: lfd f1, 0(r16)\n\t" /* load fp registers from (r16) */ - "lfd f2, 8(r16)\n\t" - "lfd f3, 16(r16)\n\t" - "lfd f4, 24(r16)\n\t" - "lfd f5, 32(r16)\n\t" - "lfd f6, 40(r16)\n\t" - "lfd f7, 48(r16)\n\t" - "lfd f8, 56(r16)\n\t" - "lfd f9, 64(r16)\n\t" - "lfd f10, 72(r16)\n\t" - "lfd f11, 80(r16)\n\t" - "lfd f12, 88(r16)\n\t" - "lfd f13, 96(r16)\n\t" + "stwu r14,24(r1)\n\t" /* r14 <- begin of parameters */ + "cmpwi cr0,r5,0\n\t" /* copy r5 bytes from (r6) to (r14) */ + "ble cr0,L3\n\t" + "mtctr r5\n" +"LX: lbz r0,0(r6)\n\t" + "addi r6,r6,1\n\t" + "stb r0,0(r14)\n\t" + "addi r14,r14,1\n" +"L3: lfd f1, 0(r16)\n\t" /* load fp registers from (r16) */ + "lfd f2, 8(r16)\n\t" + "lfd f3, 16(r16)\n\t" + "lfd f4, 24(r16)\n\t" + "lfd f5, 32(r16)\n\t" + "lfd f6, 40(r16)\n\t" + "lfd f7, 48(r16)\n\t" + "lfd f8, 56(r16)\n\t" + "lfd f9, 64(r16)\n\t" + "lfd f10, 72(r16)\n\t" + "lfd f11, 80(r16)\n\t" + "lfd f12, 88(r16)\n\t" + "lfd f13, 96(r16)\n\t" - "lwz r6, 16(r17)\n\t" /* load int registers from (r17) */ - "lwz r7, 20(r17)\n\t" - "lwz r8, 24(r17)\n\t" - "lwz r9, 28(r17)\n\t" - "lwz r10, 32(r17)\n\t" - "lwz r5, 8(r17)\n\t" - "lwz r4, 4(r17)\n\t" - "lwz r3, 0(r17)\n\t" + "lwz r6, 16(r17)\n\t" /* load int registers from (r17) */ + "lwz r7, 20(r17)\n\t" + "lwz r8, 24(r17)\n\t" + "lwz r9, 28(r17)\n\t" + "lwz r10, 32(r17)\n\t" + "lwz r5, 8(r17)\n\t" + "lwz r4, 4(r17)\n\t" + "lwz r3, 0(r17)\n\t" - "mtctr r15\n\t" /* call the function stored in r15 */ - "bctrl \n\t" - "mr r1,r29\n\t" /* restore stack and return pointer */ - "lwz r0,8(r1)\n\t" - "mtlr r0\n\t" - "stw r3,0(r17)\n\t" /* store function's output */ - "stw r4,4(r17)\n\t" - "stfd f1,0(r16)\n\t" + "mtctr r15\n\t" /* call the function stored in r15 */ + "bctrl \n\t" + "mr r1,r29\n\t" /* restore stack and return pointer */ + "lwz r0,8(r1)\n\t" + "mtlr r0\n\t" + "stw r3,0(r17)\n\t" /* store function's output */ + "stw r4,4(r17)\n\t" + "stfd f1,0(r16)\n\t" :: [bufsize] "r" (bufsize), [buf] "r" (buf), [registers] "r" (registers->registers), - [fp_registers] "r" (registers->fp_registers), [fptr] "r" (_f_ptr) - : "r5","r6","r17","r16","r29","r13","r14"); + [fp_registers] "r" (registers->fp_registers), [fptr] "r" (_f_ptr) + : "r5","r6","r17","r16","r29","r13","r14"); - void *data = registers->registers; - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.i = *((unsigned long *)data); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = *((void **)data); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = *((char *)data); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = *((cl_object *)data); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = registers->fp_registers[0]; - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = registers->fp_registers[0]; - } + void *data = registers->registers; + if (return_type <= ECL_FFI_UNSIGNED_LONG) { + fficall->output.i = *((unsigned long *)data); + } else if (return_type == ECL_FFI_POINTER_VOID) { + fficall->output.pv = *((void **)data); + } else if (return_type == ECL_FFI_CSTRING) { + fficall->output.pc = *((char *)data); + } else if (return_type == ECL_FFI_OBJECT) { + fficall->output.o = *((cl_object *)data); + } else if (return_type == ECL_FFI_FLOAT) { + fficall->output.f = registers->fp_registers[0]; + } else if (return_type == ECL_FFI_DOUBLE) { + fficall->output.d = registers->fp_registers[0]; + } } void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) { - exit(0); + exit(0); } diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index 1f66ed472..e3c784746 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -22,21 +22,21 @@ struct ecl_fficall_reg * ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) { - /* No need to prepare registers */ - return 0; + /* No need to prepare registers */ + return 0; } void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) { - int i; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; - case ECL_FFI_BYTE: i = data->b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; - case ECL_FFI_SHORT: i = data->s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; + int i; + switch (type) { + case ECL_FFI_CHAR: i = data->c; goto INT; + case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; + case ECL_FFI_BYTE: i = data->b; goto INT; + case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; + case ECL_FFI_SHORT: i = data->s; goto INT; + case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; #ifdef ecl_uint8_t case ECL_FFI_INT8_T: i = data->i8; goto INT; case ECL_FFI_UINT8_T: i = data->u8; goto INT; @@ -45,30 +45,30 @@ ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) case ECL_FFI_INT16_T: i = data->i16; goto INT; case ECL_FFI_UINT16_T: i = data->u16; goto INT; #endif - case ECL_FFI_INT: - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_INT: - case ECL_FFI_UNSIGNED_LONG: + case ECL_FFI_INT: + case ECL_FFI_LONG: + case ECL_FFI_UNSIGNED_INT: + case ECL_FFI_UNSIGNED_LONG: #ifdef ecl_uint32_t case ECL_FFI_INT32_T: case ECL_FFI_UINT32_T: #endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->i; - INT: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_int(i); - break; - case ECL_FFI_DOUBLE: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_bytes(&data->d, sizeof(double)); - break; - case ECL_FFI_FLOAT: - ecl_fficall_align(sizeof(int)); - ecl_fficall_push_bytes(&data->f, sizeof(float)); - break; + case ECL_FFI_POINTER_VOID: + case ECL_FFI_CSTRING: + case ECL_FFI_OBJECT: + i = data->i; + INT: + ecl_fficall_align(sizeof(int)); + ecl_fficall_push_int(i); + break; + case ECL_FFI_DOUBLE: + ecl_fficall_align(sizeof(int)); + ecl_fficall_push_bytes(&data->d, sizeof(double)); + break; + case ECL_FFI_FLOAT: + ecl_fficall_align(sizeof(int)); + ecl_fficall_push_bytes(&data->f, sizeof(float)); + break; #ifdef ecl_uint64_t case ECL_FFI_UINT64_T: case ECL_FFI_INT64_T: @@ -83,170 +83,170 @@ ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) ecl_fficall_push_bytes(&data->ull, sizeof(unsigned long long)); break; #endif - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } + case ECL_FFI_VOID: + FEerror("VOID is not a valid argument type for a C function", 0); + } } void ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) { - int bufsize = fficall->buffer_size; - char* buf = fficall->buffer; - char* stack_p; + int bufsize = fficall->buffer_size; + char* buf = fficall->buffer; + char* stack_p; #ifdef _MSC_VER - __asm - { - mov stack_p,esp - sub esp,bufsize - mov esi,buf - mov edi,esp - mov ecx,bufsize - rep movsb - } + __asm + { + mov stack_p,esp + sub esp,bufsize + mov esi,buf + mov edi,esp + mov ecx,bufsize + rep movsb + } #else - asm volatile ( - "movl %%esp, %0\n\t" - "subl %1, %%esp\n\t" - "movl %2, %%esi\n\t" - "movl %%esp, %%edi\n\t" - "rep\n\t" + asm volatile ( + "movl %%esp, %0\n\t" + "subl %1, %%esp\n\t" + "movl %2, %%esi\n\t" + "movl %%esp, %%edi\n\t" + "rep\n\t" "movsb\n\t" : "=a" (stack_p) : "c" (bufsize), "d" (buf) : "%edi", "%esi"); #endif - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.i = ((int (*)())f_ptr)(); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = ((void * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = ((char * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = ((cl_object (*)())f_ptr)(); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = ((float (*)())f_ptr)(); - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = ((double (*)())f_ptr)(); + if (return_type <= ECL_FFI_UNSIGNED_LONG) { + fficall->output.i = ((int (*)())f_ptr)(); + } else if (return_type == ECL_FFI_POINTER_VOID) { + fficall->output.pv = ((void * (*)())f_ptr)(); + } else if (return_type == ECL_FFI_CSTRING) { + fficall->output.pc = ((char * (*)())f_ptr)(); + } else if (return_type == ECL_FFI_OBJECT) { + fficall->output.o = ((cl_object (*)())f_ptr)(); + } else if (return_type == ECL_FFI_FLOAT) { + fficall->output.f = ((float (*)())f_ptr)(); + } else if (return_type == ECL_FFI_DOUBLE) { + fficall->output.d = ((double (*)())f_ptr)(); } #ifdef ecl_uint8_t else if (return_type == ECL_FFI_INT8_T) { fficall->output.i8 = ((ecl_int8_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { + } else if (return_type == ECL_FFI_UINT16_T) { fficall->output.u8 = ((ecl_uint8_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint16_t else if (return_type == ECL_FFI_INT16_T) { fficall->output.i16 = ((ecl_int16_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { + } else if (return_type == ECL_FFI_UINT16_T) { fficall->output.u16 = ((ecl_uint16_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint32_t else if (return_type == ECL_FFI_INT32_T) { fficall->output.i32 = ((ecl_int32_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { + } else if (return_type == ECL_FFI_UINT32_T) { fficall->output.u32 = ((ecl_uint32_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint64_t else if (return_type == ECL_FFI_INT64_T) { fficall->output.i64 = ((ecl_int64_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { + } else if (return_type == ECL_FFI_UINT32_T) { fficall->output.u64 = ((ecl_uint64_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_long_long_t else if (return_type == ECL_FFI_LONG_LONG) { fficall->output.ll = ((ecl_long_long_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { + } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { fficall->output.ull = ((ecl_ulong_long_t (*)())f_ptr)(); - } + } #endif else { - ((void (*)())f_ptr)(); - } + ((void (*)())f_ptr)(); + } #ifdef _MSC_VER - __asm mov esp,stack_p + __asm mov esp,stack_p #else - asm volatile ("mov %0,%%esp" :: "a" (stack_p)); + asm volatile ("mov %0,%%esp" :: "a" (stack_p)); #endif } static void ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) { - cl_object fun, rtype, argtypes; - cl_object result; - cl_index i, size; - union ecl_ffi_values output; - enum ecl_ffi_tag tag; - cl_env_ptr env = ecl_process_env(); + cl_object fun, rtype, argtypes; + cl_object result; + cl_index i, size; + union ecl_ffi_values output; + enum ecl_ffi_tag tag; + cl_env_ptr env = ecl_process_env(); - ECL_BUILD_STACK_FRAME(env, frame, aux); + ECL_BUILD_STACK_FRAME(env, frame, aux); - fun = CAR(cbk_info); - rtype = CADR(cbk_info); - argtypes = CADDR(cbk_info); + fun = CAR(cbk_info); + rtype = CADR(cbk_info); + argtypes = CADDR(cbk_info); - arg_buffer += 4; /* Skip return address */ - for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { - tag = ecl_foreign_type_code(CAR(argtypes)); - size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); - result = ecl_foreign_data_ref_elt(arg_buffer, tag); - ecl_stack_frame_push(frame,result); - { - int mask = 3; - int sp = (size + mask) & ~mask; - arg_buffer += (sp); - } - } + arg_buffer += 4; /* Skip return address */ + for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { + tag = ecl_foreign_type_code(CAR(argtypes)); + size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); + result = ecl_foreign_data_ref_elt(arg_buffer, tag); + ecl_stack_frame_push(frame,result); + { + int mask = 3; + int sp = (size + mask) & ~mask; + arg_buffer += (sp); + } + } - result = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); + result = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); - tag = ecl_foreign_type_code(rtype); - memset(&output, 0, sizeof(output)); - ecl_foreign_data_set_elt(&output, tag, result); + tag = ecl_foreign_type_code(rtype); + memset(&output, 0, sizeof(output)); + ecl_foreign_data_set_elt(&output, tag, result); - switch (tag) { - case ECL_FFI_CHAR: i = output.c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT; - case ECL_FFI_BYTE: i = output.b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT; + switch (tag) { + case ECL_FFI_CHAR: i = output.c; goto INT; + case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT; + case ECL_FFI_BYTE: i = output.b; goto INT; + case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT; #ifdef ecl_uint8_t - case ECL_FFI_INT8_T: i = output.i8; goto INT; - case ECL_FFI_UINT8_T: i = output.u8; goto INT; + case ECL_FFI_INT8_T: i = output.i8; goto INT; + case ECL_FFI_UINT8_T: i = output.u8; goto INT; #endif #ifdef ecl_uint16_t case ECL_FFI_INT16_T: #endif - case ECL_FFI_SHORT: i = output.s; goto INT; + case ECL_FFI_SHORT: i = output.s; goto INT; #ifdef ecl_uint16_t case ECL_FFI_UINT16_T: #endif - case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT; - case ECL_FFI_POINTER_VOID: - case ECL_FFI_OBJECT: - case ECL_FFI_CSTRING: - case ECL_FFI_INT: - case ECL_FFI_UNSIGNED_INT: + case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT; + case ECL_FFI_POINTER_VOID: + case ECL_FFI_OBJECT: + case ECL_FFI_CSTRING: + case ECL_FFI_INT: + case ECL_FFI_UNSIGNED_INT: #ifdef ecl_uint32_t case ECL_FFI_INT32_T: case ECL_FFI_UINT32_T: #endif - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: - i = output.i; + case ECL_FFI_LONG: + case ECL_FFI_UNSIGNED_LONG: + i = output.i; INT: #ifdef _MSC_VER - __asm mov eax,i + __asm mov eax,i #else - { - register int eax asm("eax"); - eax = i; - } + { + register int eax asm("eax"); + eax = i; + } #endif - return; + return; #if defined(ecl_long_long_t) || defined(ecl_uint64_t) # ifdef ecl_long_long_t case ECL_FFI_LONG_LONG: @@ -257,84 +257,84 @@ INT: case ECL_FFI_UINT64_T: # endif # ifdef _MSC_VER - __asm mov eax,output.l2[0] + __asm mov eax,output.l2[0] __asm mov edx,output.l2[1] # else - { - register int eax asm("eax"); - register int edx asm("edx"); - eax = output.l2[0]; + { + register int eax asm("eax"); + register int edx asm("edx"); + eax = output.l2[0]; edx = output.l2[1]; - } + } # endif return; #endif /* ecl_long_long_t */ - case ECL_FFI_DOUBLE: { + case ECL_FFI_DOUBLE: { #ifdef _MSC_VER - __asm fld output.d + __asm fld output.d #else - { - asm("fldl (%0)" :: "a" (&output.d)); - } + { + asm("fldl (%0)" :: "a" (&output.d)); + } #endif - return; - } - case ECL_FFI_FLOAT: { + return; + } + case ECL_FFI_FLOAT: { #ifdef _MSC_VER - __asm fld output.f + __asm fld output.f #else - { - asm("flds (%0)" :: "a" (&output.f)); - } + { + asm("flds (%0)" :: "a" (&output.f)); + } #endif - return; - } - case ECL_FFI_VOID: - return; - } + return; + } + case ECL_FFI_VOID: + return; + } } void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) { - /* - * push %esp 54 - * pushl 68 - * call ecl_dynamic_callback_call E8 - * [ Here we could use also lea 4(%esp), %esp, but %ecx seems to be free ] - * pop %ecx 59 - * pop %ecx 59 - * ret c3 - * nop 90 - * nop 90 - */ - char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*16, 4); - *(char*) (buf+0) = 0x54; - *(char*) (buf+1) = 0x68; - *(long*) (buf+2) = (long)data; - *(unsigned char*) (buf+6) = 0xE8; - *(long*) (buf+7) = (long)ecl_dynamic_callback_execute - (long)(buf+11); - *(char*) (buf+11) = 0x59; - *(char*) (buf+12) = 0x59; - if (cc_type == ECL_FFI_CC_CDECL) { - *(unsigned char*) (buf+13) = 0xc3; - *(unsigned short*)(buf+14) = 0x9090; - } else { - cl_object arg_types = CADDR(data); - int byte_size = 0; - int mask = 3; + /* + * push %esp 54 + * pushl 68 + * call ecl_dynamic_callback_call E8 + * [ Here we could use also lea 4(%esp), %esp, but %ecx seems to be free ] + * pop %ecx 59 + * pop %ecx 59 + * ret c3 + * nop 90 + * nop 90 + */ + char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*16, 4); + *(char*) (buf+0) = 0x54; + *(char*) (buf+1) = 0x68; + *(long*) (buf+2) = (long)data; + *(unsigned char*) (buf+6) = 0xE8; + *(long*) (buf+7) = (long)ecl_dynamic_callback_execute - (long)(buf+11); + *(char*) (buf+11) = 0x59; + *(char*) (buf+12) = 0x59; + if (cc_type == ECL_FFI_CC_CDECL) { + *(unsigned char*) (buf+13) = 0xc3; + *(unsigned short*)(buf+14) = 0x9090; + } else { + cl_object arg_types = CADDR(data); + int byte_size = 0; + int mask = 3; - while (CONSP(arg_types)) { - int sz = ecl_fixnum(si_size_of_foreign_elt_type(CAR(arg_types))); - byte_size += ((sz+mask)&(~mask)); - arg_types = CDR(arg_types); - } + while (CONSP(arg_types)) { + int sz = ecl_fixnum(si_size_of_foreign_elt_type(CAR(arg_types))); + byte_size += ((sz+mask)&(~mask)); + arg_types = CDR(arg_types); + } - *(unsigned char*) (buf+13) = 0xc2; - *(unsigned short*)(buf+14) = (unsigned short)byte_size; - } + *(unsigned char*) (buf+13) = 0xc2; + *(unsigned short*)(buf+14) = (unsigned short)byte_size; + } - return buf; + return buf; } #endif diff --git a/src/c/arch/ffi_x86_64.d b/src/c/arch/ffi_x86_64.d index 26b689fcc..08bca0bad 100644 --- a/src/c/arch/ffi_x86_64.d +++ b/src/c/arch/ffi_x86_64.d @@ -23,264 +23,264 @@ #define MAX_FP_REGISTERS 8 struct ecl_fficall_reg { - long int_registers[MAX_INT_REGISTERS]; - int int_registers_size; - double fp_registers[MAX_FP_REGISTERS]; - int fp_registers_size; + long int_registers[MAX_INT_REGISTERS]; + int int_registers_size; + double fp_registers[MAX_FP_REGISTERS]; + int fp_registers_size; }; struct ecl_fficall_reg * ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) { - if (registers == 0) { - registers = ecl_alloc_atomic_align(sizeof(*registers), sizeof(long)); - } - registers->int_registers_size = 0; - registers->fp_registers_size = 0; + if (registers == 0) { + registers = ecl_alloc_atomic_align(sizeof(*registers), sizeof(long)); + } + registers->int_registers_size = 0; + registers->fp_registers_size = 0; return registers; } void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type) { - long i; - struct ecl_fficall *fficall = cl_env.fficall; - struct ecl_fficall_reg *registers = fficall->registers; - switch (type) { - case ECL_FFI_CHAR: i = data->c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; + long i; + struct ecl_fficall *fficall = cl_env.fficall; + struct ecl_fficall_reg *registers = fficall->registers; + switch (type) { + case ECL_FFI_CHAR: i = data->c; goto INT; + case ECL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT; #ifdef ecl_uint8_t case ECL_FFI_INT8_T: i = data->i8; goto INT; case ECL_FFI_UINT8_T: i = data->u8; goto INT; #endif - case ECL_FFI_BYTE: i = data->b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; + case ECL_FFI_BYTE: i = data->b; goto INT; + case ECL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT; #ifdef ecl_uint16_t case ECL_FFI_INT16_T: i = data->i16; goto INT; case ECL_FFI_UINT16_T: i = data->u16; goto INT; #endif - case ECL_FFI_SHORT: i = data->s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; + case ECL_FFI_SHORT: i = data->s; goto INT; + case ECL_FFI_UNSIGNED_SHORT: i = data->us; goto INT; #ifdef ecl_uint32_t case ECL_FFI_INT32_T: i = data->i32; goto INT; case ECL_FFI_UINT32_T: i = data->u32; goto INT; #endif - case ECL_FFI_INT: i = data->i; goto INT; - case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: + case ECL_FFI_INT: i = data->i; goto INT; + case ECL_FFI_UNSIGNED_INT: i = data->ui; goto INT; + case ECL_FFI_LONG: + case ECL_FFI_UNSIGNED_LONG: #ifdef ecl_uint64_t case ECL_FFI_INT64_T: case ECL_FFI_UINT64_T: #endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_CSTRING: - case ECL_FFI_OBJECT: - i = data->l; - INT: - if (registers->int_registers_size < MAX_INT_REGISTERS) { - registers->int_registers[registers->int_registers_size++] = i; - } else { - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&i, sizeof(long)); - } - break; - case ECL_FFI_DOUBLE: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - registers->fp_registers[registers->fp_registers_size++] = data->d; - } else { - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->d, sizeof(double)); - } - break; - case ECL_FFI_FLOAT: - if (registers->fp_registers_size < MAX_FP_REGISTERS) { - memset(®isters->fp_registers[registers->fp_registers_size], 0, sizeof(double)); - (*(float*)(®isters->fp_registers[registers->fp_registers_size++])) = (float)data->f; - } else { - i = 0; - ecl_fficall_align(sizeof(long)); - ecl_fficall_push_bytes(&data->f, sizeof(float)); - ecl_fficall_push_bytes(&i, sizeof(float)); - } - break; - case ECL_FFI_VOID: - FEerror("VOID is not a valid argument type for a C function", 0); - } + case ECL_FFI_POINTER_VOID: + case ECL_FFI_CSTRING: + case ECL_FFI_OBJECT: + i = data->l; + INT: + if (registers->int_registers_size < MAX_INT_REGISTERS) { + registers->int_registers[registers->int_registers_size++] = i; + } else { + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&i, sizeof(long)); + } + break; + case ECL_FFI_DOUBLE: + if (registers->fp_registers_size < MAX_FP_REGISTERS) { + registers->fp_registers[registers->fp_registers_size++] = data->d; + } else { + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&data->d, sizeof(double)); + } + break; + case ECL_FFI_FLOAT: + if (registers->fp_registers_size < MAX_FP_REGISTERS) { + memset(®isters->fp_registers[registers->fp_registers_size], 0, sizeof(double)); + (*(float*)(®isters->fp_registers[registers->fp_registers_size++])) = (float)data->f; + } else { + i = 0; + ecl_fficall_align(sizeof(long)); + ecl_fficall_push_bytes(&data->f, sizeof(float)); + ecl_fficall_push_bytes(&i, sizeof(float)); + } + break; + case ECL_FFI_VOID: + FEerror("VOID is not a valid argument type for a C function", 0); + } } void ecl_fficall_execute(void *_f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type) { - struct ecl_fficall_reg *registers = fficall->registers; - long bufsize = fficall->buffer_size; - char* buf = fficall->buffer; - char* stack_p; - register void* f_ptr asm("r10"); + struct ecl_fficall_reg *registers = fficall->registers; + long bufsize = fficall->buffer_size; + char* buf = fficall->buffer; + char* stack_p; + register void* f_ptr asm("r10"); - ecl_fficall_align(16); - bufsize = fficall->buffer_size; - f_ptr = _f_ptr; + ecl_fficall_align(16); + bufsize = fficall->buffer_size; + f_ptr = _f_ptr; - asm volatile ( - "mov %%rsp, %0\n\t" - "sub %1, %%rsp\n\t" - "mov %2, %%rsi\n\t" - "mov %%rsp, %%rdi\n\t" - "rep\n\t" + asm volatile ( + "mov %%rsp, %0\n\t" + "sub %1, %%rsp\n\t" + "mov %2, %%rsi\n\t" + "mov %%rsp, %%rdi\n\t" + "rep\n\t" "movsb\n\t" : "=a" (stack_p) : "c" (bufsize), "d" (buf) : "%rdi", "%rsi"); - asm volatile ( - "mov (%%rax), %%rdi\n\t" - "mov 0x08(%%rax), %%rsi\n\t" - "mov 0x10(%%rax), %%rdx\n\t" - "mov 0x18(%%rax), %%rcx\n\t" - "mov 0x20(%%rax), %%r8\n\t" - "mov 0x28(%%rax), %%r9\n\t" - :: "a" (registers->int_registers)); + asm volatile ( + "mov (%%rax), %%rdi\n\t" + "mov 0x08(%%rax), %%rsi\n\t" + "mov 0x10(%%rax), %%rdx\n\t" + "mov 0x18(%%rax), %%rcx\n\t" + "mov 0x20(%%rax), %%r8\n\t" + "mov 0x28(%%rax), %%r9\n\t" + :: "a" (registers->int_registers)); - asm volatile ( - "movsd (%%rax), %%xmm0\n\t" - "movsd 0x08(%%rax), %%xmm1\n\t" - "movsd 0x10(%%rax), %%xmm2\n\t" - "movsd 0x18(%%rax), %%xmm3\n\t" - "movsd 0x20(%%rax), %%xmm4\n\t" - "movsd 0x28(%%rax), %%xmm5\n\t" - "movsd 0x30(%%rax), %%xmm6\n\t" - "movsd 0x38(%%rax), %%xmm7\n\t" - :: "a" (registers->fp_registers)); + asm volatile ( + "movsd (%%rax), %%xmm0\n\t" + "movsd 0x08(%%rax), %%xmm1\n\t" + "movsd 0x10(%%rax), %%xmm2\n\t" + "movsd 0x18(%%rax), %%xmm3\n\t" + "movsd 0x20(%%rax), %%xmm4\n\t" + "movsd 0x28(%%rax), %%xmm5\n\t" + "movsd 0x30(%%rax), %%xmm6\n\t" + "movsd 0x38(%%rax), %%xmm7\n\t" + :: "a" (registers->fp_registers)); - if (return_type <= ECL_FFI_UNSIGNED_LONG) { - fficall->output.ul = ((unsigned long (*)())f_ptr)(); - } else if (return_type == ECL_FFI_POINTER_VOID) { - fficall->output.pv = ((void * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_CSTRING) { - fficall->output.pc = ((char * (*)())f_ptr)(); - } else if (return_type == ECL_FFI_OBJECT) { - fficall->output.o = ((cl_object (*)())f_ptr)(); - } else if (return_type == ECL_FFI_FLOAT) { - fficall->output.f = ((float (*)())f_ptr)(); - } else if (return_type == ECL_FFI_DOUBLE) { - fficall->output.d = ((double (*)())f_ptr)(); - } + if (return_type <= ECL_FFI_UNSIGNED_LONG) { + fficall->output.ul = ((unsigned long (*)())f_ptr)(); + } else if (return_type == ECL_FFI_POINTER_VOID) { + fficall->output.pv = ((void * (*)())f_ptr)(); + } else if (return_type == ECL_FFI_CSTRING) { + fficall->output.pc = ((char * (*)())f_ptr)(); + } else if (return_type == ECL_FFI_OBJECT) { + fficall->output.o = ((cl_object (*)())f_ptr)(); + } else if (return_type == ECL_FFI_FLOAT) { + fficall->output.f = ((float (*)())f_ptr)(); + } else if (return_type == ECL_FFI_DOUBLE) { + fficall->output.d = ((double (*)())f_ptr)(); + } #ifdef ecl_uint8_t else if (return_type == ECL_FFI_INT8_T) { fficall->output.i8 = ((ecl_int8_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { + } else if (return_type == ECL_FFI_UINT16_T) { fficall->output.u8 = ((ecl_uint8_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint16_t else if (return_type == ECL_FFI_INT16_T) { fficall->output.i16 = ((ecl_int16_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT16_T) { + } else if (return_type == ECL_FFI_UINT16_T) { fficall->output.u16 = ((ecl_uint16_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint32_t else if (return_type == ECL_FFI_INT32_T) { fficall->output.i32 = ((ecl_int32_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { + } else if (return_type == ECL_FFI_UINT32_T) { fficall->output.u32 = ((ecl_uint32_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_uint64_t else if (return_type == ECL_FFI_INT64_T) { fficall->output.i64 = ((ecl_int64_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UINT32_T) { + } else if (return_type == ECL_FFI_UINT32_T) { fficall->output.u64 = ((ecl_uint64_t (*)())f_ptr)(); - } + } #endif #ifdef ecl_long_long_t else if (return_type == ECL_FFI_LONG_LONG) { fficall->output.ll = ((ecl_long_long_t (*)())f_ptr)(); - } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { + } else if (return_type == ECL_FFI_UNSIGNED_LONG_LONG) { fficall->output.ull = ((ecl_ulong_long_t (*)())f_ptr)(); - } + } #endif else { - ((void (*)())f_ptr)(); - } + ((void (*)())f_ptr)(); + } - asm volatile ("mov %0,%%rsp" :: "a" (stack_p)); + asm volatile ("mov %0,%%rsp" :: "a" (stack_p)); } static void ecl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i6, - double f1, double f2, double f3, double f4, - double f5, double f6, double f7, double f8, - cl_object cbk_info, char *arg_buffer) + double f1, double f2, double f3, double f4, + double f5, double f6, double f7, double f8, + cl_object cbk_info, char *arg_buffer) { - cl_object fun, rtype, argtypes; - cl_object result; - cl_index i, size, i_reg_index, f_reg_index; - union ecl_ffi_values output; - enum ecl_ffi_tag tag; - long i_reg[MAX_INT_REGISTERS]; - double f_reg[MAX_FP_REGISTERS]; - cl_env_ptr env = ecl_process_env(); + cl_object fun, rtype, argtypes; + cl_object result; + cl_index i, size, i_reg_index, f_reg_index; + union ecl_ffi_values output; + enum ecl_ffi_tag tag; + long i_reg[MAX_INT_REGISTERS]; + double f_reg[MAX_FP_REGISTERS]; + cl_env_ptr env = ecl_process_env(); - ECL_BUILD_STACK_FRAME(env, frame, aux); + ECL_BUILD_STACK_FRAME(env, frame, aux); - fun = CAR(cbk_info); - rtype = CADR(cbk_info); - argtypes = CADDR(cbk_info); + fun = CAR(cbk_info); + rtype = CADR(cbk_info); + argtypes = CADDR(cbk_info); - i_reg_index = f_reg_index = 0; - i_reg[0] = i1; - i_reg[1] = i2; - i_reg[2] = i3; - i_reg[3] = i4; - i_reg[4] = i5; - i_reg[5] = i6; - f_reg[0] = f1; - f_reg[1] = f2; - f_reg[2] = f3; - f_reg[3] = f4; - f_reg[4] = f5; - f_reg[5] = f6; - f_reg[6] = f7; - f_reg[7] = f8; + i_reg_index = f_reg_index = 0; + i_reg[0] = i1; + i_reg[1] = i2; + i_reg[2] = i3; + i_reg[3] = i4; + i_reg[4] = i5; + i_reg[5] = i6; + f_reg[0] = f1; + f_reg[1] = f2; + f_reg[2] = f3; + f_reg[3] = f4; + f_reg[4] = f5; + f_reg[5] = f6; + f_reg[6] = f7; + f_reg[7] = f8; - arg_buffer += 2*sizeof(void*); /* Skip return address and base pointer */ - for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { - tag = ecl_foreign_type_code(CAR(argtypes)); - size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); - if (tag <= ECL_FFI_OBJECT) { - if (i_reg_index < MAX_INT_REGISTERS) - result = ecl_foreign_data_ref_elt(&i_reg[i_reg_index++], tag); - else - goto ARG_FROM_STACK; - } else if (tag <= ECL_FFI_DOUBLE) { - if (f_reg_index < MAX_FP_REGISTERS) - result = ecl_foreign_data_ref_elt(&f_reg[f_reg_index++], tag); - else - goto ARG_FROM_STACK; - } else { + arg_buffer += 2*sizeof(void*); /* Skip return address and base pointer */ + for (i=0; !ecl_endp(argtypes); argtypes = CDR(argtypes), i++) { + tag = ecl_foreign_type_code(CAR(argtypes)); + size = ecl_fixnum(si_size_of_foreign_elt_type(CAR(argtypes))); + if (tag <= ECL_FFI_OBJECT) { + if (i_reg_index < MAX_INT_REGISTERS) + result = ecl_foreign_data_ref_elt(&i_reg[i_reg_index++], tag); + else + goto ARG_FROM_STACK; + } else if (tag <= ECL_FFI_DOUBLE) { + if (f_reg_index < MAX_FP_REGISTERS) + result = ecl_foreign_data_ref_elt(&f_reg[f_reg_index++], tag); + else + goto ARG_FROM_STACK; + } else { ARG_FROM_STACK: - result = ecl_foreign_data_ref_elt(arg_buffer, tag); - { - int mask = 7; - int sp = (size + mask) & ~mask; - arg_buffer += (sp); - } - } - ecl_stack_frame_push(frame, result); - } + result = ecl_foreign_data_ref_elt(arg_buffer, tag); + { + int mask = 7; + int sp = (size + mask) & ~mask; + arg_buffer += (sp); + } + } + ecl_stack_frame_push(frame, result); + } - result = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); + result = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); - tag = ecl_foreign_type_code(rtype); - memset(&output, 0, sizeof(output)); - ecl_foreign_data_set_elt(&output, tag, result); + tag = ecl_foreign_type_code(rtype); + memset(&output, 0, sizeof(output)); + ecl_foreign_data_set_elt(&output, tag, result); - switch (tag) { - case ECL_FFI_CHAR: i = output.c; goto INT; - case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT; - case ECL_FFI_BYTE: i = output.b; goto INT; - case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT; + switch (tag) { + case ECL_FFI_CHAR: i = output.c; goto INT; + case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT; + case ECL_FFI_BYTE: i = output.b; goto INT; + case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT; #ifdef ecl_uint8_t case ECL_FFI_INT8_T: i = output.i8; goto INT; case ECL_FFI_UINT8_T: i = output.u8; goto INT; @@ -289,80 +289,80 @@ ARG_FROM_STACK: case ECL_FFI_INT16_T: i = output.i16; goto INT; case ECL_FFI_UINT16_T: i = output.u16; goto INT; #endif - case ECL_FFI_SHORT: i = output.s; goto INT; - case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT; + case ECL_FFI_SHORT: i = output.s; goto INT; + case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT; #ifdef ecl_uint32_t case ECL_FFI_INT32_T: i = output.i32; goto INT; case ECL_FFI_UINT32_T: i = output.u32; goto INT; #endif - case ECL_FFI_POINTER_VOID: - case ECL_FFI_OBJECT: - case ECL_FFI_CSTRING: - case ECL_FFI_INT: - case ECL_FFI_UNSIGNED_INT: - case ECL_FFI_LONG: - case ECL_FFI_UNSIGNED_LONG: + case ECL_FFI_POINTER_VOID: + case ECL_FFI_OBJECT: + case ECL_FFI_CSTRING: + case ECL_FFI_INT: + case ECL_FFI_UNSIGNED_INT: + case ECL_FFI_LONG: + case ECL_FFI_UNSIGNED_LONG: #ifdef ecl_uint64_t case ECL_FFI_INT64_T: case ECL_FFI_UINT64_T: #endif - i = output.i; + i = output.i; INT: - { - register long eax asm("rax"); - eax = i; - } - return; - case ECL_FFI_DOUBLE: { - { - asm("movsd (%0),%%xmm0" :: "a" (&output.d)); - } - return; - } - case ECL_FFI_FLOAT: { - { - asm("movss (%0),%%xmm0" :: "a" (&output.f)); - } - return; - } - case ECL_FFI_VOID: - return; - } + { + register long eax asm("rax"); + eax = i; + } + return; + case ECL_FFI_DOUBLE: { + { + asm("movsd (%0),%%xmm0" :: "a" (&output.d)); + } + return; + } + case ECL_FFI_FLOAT: { + { + asm("movss (%0),%%xmm0" :: "a" (&output.f)); + } + return; + } + case ECL_FFI_VOID: + return; + } } void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type) { - /* - * push %rbp 55 - * push %rsp 54 - * mov ,%rax 48 b8 - * push %rax 50 - * mov ,%rax 48 b8 - * callq *%rax 48 ff d0 - * pop %rcx 59 - * pop %rcx 59 - * pop %rbp 5d - * ret c3 - * nop 90 - * nop 90 - */ - char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*32, 8); - *(char*) (buf+0) = 0x55; - *(char*) (buf+1) = 0x54; - *(short*)(buf+2) = 0xb848; - *(long*) (buf+4) = (long)data; - *(char*) (buf+12) = 0x50; - *(short*)(buf+13) = 0xb848; - *(long*) (buf+15) = (long)ecl_dynamic_callback_execute; - *(int*) (buf+23) = (int)0x00d0ff48; /* leading null byte is overwritten */ - *(char*) (buf+26) = 0x59; - *(char*) (buf+27) = 0x59; - *(char*) (buf+28) = 0x5d; - *(char*) (buf+29) = 0xc3; - *(short*)(buf+30) = 0x9090; + /* + * push %rbp 55 + * push %rsp 54 + * mov ,%rax 48 b8 + * push %rax 50 + * mov ,%rax 48 b8 + * callq *%rax 48 ff d0 + * pop %rcx 59 + * pop %rcx 59 + * pop %rbp 5d + * ret c3 + * nop 90 + * nop 90 + */ + char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*32, 8); + *(char*) (buf+0) = 0x55; + *(char*) (buf+1) = 0x54; + *(short*)(buf+2) = 0xb848; + *(long*) (buf+4) = (long)data; + *(char*) (buf+12) = 0x50; + *(short*)(buf+13) = 0xb848; + *(long*) (buf+15) = (long)ecl_dynamic_callback_execute; + *(int*) (buf+23) = (int)0x00d0ff48; /* leading null byte is overwritten */ + *(char*) (buf+26) = 0x59; + *(char*) (buf+27) = 0x59; + *(char*) (buf+28) = 0x5d; + *(char*) (buf+29) = 0xc3; + *(short*)(buf+30) = 0x9090; - return buf; + return buf; } #endif diff --git a/src/c/array.d b/src/c/array.d index e6b8e765b..27818c0e9 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -53,7 +53,7 @@ static void FEbad_aet() ecl_attr_noreturn; static void FEbad_aet() { - FEerror( + FEerror( "A routine from ECL got an object with a bad array element type.\n" "If you are running a standard copy of ECL, please report this bug.\n" "If you are embedding ECL into an application, please ensure you\n" @@ -63,7 +63,7 @@ FEbad_aet() static cl_index out_of_bounds_error(cl_index ndx, cl_object x) { - cl_object type = cl_list(3, @'integer', ecl_make_fixnum(0), + cl_object type = cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(x->array.dim)); FEwrong_type_argument(ecl_make_integer(ndx), type); } @@ -93,114 +93,114 @@ checked_index(cl_object function, cl_object a, int which, cl_object index, cl_index ecl_to_index(cl_object n) { - switch (ecl_t_of(n)) { - case t_fixnum: { - cl_fixnum out = ecl_fixnum(n); - if (out < 0 || out >= ECL_ARRAY_DIMENSION_LIMIT) - FEtype_error_index(ECL_NIL, out); - return out; - } - default: - FEwrong_type_only_arg(@[coerce], n, @[fixnum]); - } + switch (ecl_t_of(n)) { + case t_fixnum: { + cl_fixnum out = ecl_fixnum(n); + if (out < 0 || out >= ECL_ARRAY_DIMENSION_LIMIT) + FEtype_error_index(ECL_NIL, out); + return out; + } + default: + FEwrong_type_only_arg(@[coerce], n, @[fixnum]); + } } cl_object cl_row_major_aref(cl_object x, cl_object indx) { - cl_index j = ecl_to_size(indx); - @(return ecl_aref(x, j)) + cl_index j = ecl_to_size(indx); + @(return ecl_aref(x, j)) } cl_object si_row_major_aset(cl_object x, cl_object indx, cl_object val) { - cl_index j = ecl_to_size(indx); - @(return ecl_aset(x, j, val)) + cl_index j = ecl_to_size(indx); + @(return ecl_aset(x, j, val)) } @(defun aref (x &rest indx) @ { - cl_index i, j; - cl_index r = narg - 1; - switch (ecl_t_of(x)) { - case t_array: - if (r != x->array.rank) - FEerror("Wrong number of indices.", 0); - for (i = j = 0; i < r; i++) { - cl_index s = checked_index(@[aref], x, i, + cl_index i, j; + cl_index r = narg - 1; + switch (ecl_t_of(x)) { + case t_array: + if (r != x->array.rank) + FEerror("Wrong number of indices.", 0); + for (i = j = 0; i < r; i++) { + cl_index s = checked_index(@[aref], x, i, ecl_va_arg(indx), x->array.dims[i]); - j = j*(x->array.dims[i]) + s; - } - break; - case t_vector: + j = j*(x->array.dims[i]) + s; + } + break; + case t_vector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - if (r != 1) - FEerror("Wrong number of indices.", 0); - j = checked_index(@[aref], x, -1, ecl_va_arg(indx), x->vector.dim); - break; - default: + case t_base_string: + case t_bitvector: + if (r != 1) + FEerror("Wrong number of indices.", 0); + j = checked_index(@[aref], x, -1, ecl_va_arg(indx), x->vector.dim); + break; + default: FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } - @(return ecl_aref_unsafe(x, j)); + } + @(return ecl_aref_unsafe(x, j)); } @) cl_object ecl_aref_unsafe(cl_object x, cl_index index) { - switch (x->array.elttype) { - case ecl_aet_object: - return x->array.self.t[index]; - case ecl_aet_bc: - return ECL_CODE_CHAR(x->base_string.self[index]); + switch (x->array.elttype) { + case ecl_aet_object: + return x->array.self.t[index]; + case ecl_aet_bc: + return ECL_CODE_CHAR(x->base_string.self[index]); #ifdef ECL_UNICODE - case ecl_aet_ch: + case ecl_aet_ch: return ECL_CODE_CHAR(x->string.self[index]); #endif - case ecl_aet_bit: - index += x->vector.offset; - if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT)) - return(ecl_make_fixnum(1)); - else - return(ecl_make_fixnum(0)); - case ecl_aet_fix: - return ecl_make_integer(x->array.self.fix[index]); - case ecl_aet_index: - return ecl_make_unsigned_integer(x->array.self.index[index]); - case ecl_aet_sf: - return(ecl_make_single_float(x->array.self.sf[index])); - case ecl_aet_df: - return(ecl_make_double_float(x->array.self.df[index])); - case ecl_aet_b8: - return ecl_make_uint8_t(x->array.self.b8[index]); - case ecl_aet_i8: - return ecl_make_int8_t(x->array.self.i8[index]); + case ecl_aet_bit: + index += x->vector.offset; + if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT)) + return(ecl_make_fixnum(1)); + else + return(ecl_make_fixnum(0)); + case ecl_aet_fix: + return ecl_make_integer(x->array.self.fix[index]); + case ecl_aet_index: + return ecl_make_unsigned_integer(x->array.self.index[index]); + case ecl_aet_sf: + return(ecl_make_single_float(x->array.self.sf[index])); + case ecl_aet_df: + return(ecl_make_double_float(x->array.self.df[index])); + case ecl_aet_b8: + return ecl_make_uint8_t(x->array.self.b8[index]); + case ecl_aet_i8: + return ecl_make_int8_t(x->array.self.i8[index]); #ifdef ecl_uint16_t - case ecl_aet_b16: - return ecl_make_uint16_t(x->array.self.b16[index]); - case ecl_aet_i16: - return ecl_make_int16_t(x->array.self.i16[index]); + case ecl_aet_b16: + return ecl_make_uint16_t(x->array.self.b16[index]); + case ecl_aet_i16: + return ecl_make_int16_t(x->array.self.i16[index]); #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - return ecl_make_uint32_t(x->array.self.b32[index]); - case ecl_aet_i32: - return ecl_make_int32_t(x->array.self.i32[index]); + case ecl_aet_b32: + return ecl_make_uint32_t(x->array.self.b32[index]); + case ecl_aet_i32: + return ecl_make_int32_t(x->array.self.i32[index]); #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - return ecl_make_uint64_t(x->array.self.b64[index]); - case ecl_aet_i64: - return ecl_make_int64_t(x->array.self.i64[index]); + case ecl_aet_b64: + return ecl_make_uint64_t(x->array.self.b64[index]); + case ecl_aet_i64: + return ecl_make_int64_t(x->array.self.i64[index]); #endif - default: - FEbad_aet(); - } + default: + FEbad_aet(); + } } cl_object @@ -232,138 +232,138 @@ ecl_aref1(cl_object x, cl_index index) void * ecl_row_major_ptr(cl_object x, cl_index index, cl_index bytes) { - cl_index elt_size, offset; - cl_elttype elt_type; + cl_index elt_size, offset; + cl_elttype elt_type; - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[aref], 1, x, @[array]); - } + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[aref], 1, x, @[array]); + } - elt_type = x->array.elttype; - if (ecl_unlikely(elt_type == ecl_aet_bit || elt_type == ecl_aet_object)) - FEerror("In ecl_row_major_ptr: Specialized array expected, element type ~S found.", - 1,ecl_elttype_to_symbol(elt_type)); + elt_type = x->array.elttype; + if (ecl_unlikely(elt_type == ecl_aet_bit || elt_type == ecl_aet_object)) + FEerror("In ecl_row_major_ptr: Specialized array expected, element type ~S found.", + 1,ecl_elttype_to_symbol(elt_type)); - elt_size = ecl_aet_size[elt_type]; - offset = index*elt_size; + elt_size = ecl_aet_size[elt_type]; + offset = index*elt_size; - /* don't check bounds if bytes == 0 */ + /* don't check bounds if bytes == 0 */ if (ecl_unlikely(bytes > 0 && offset + bytes > x->array.dim*elt_size)) { FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index), x->array.dim); } - return x->array.self.b8 + offset; + return x->array.self.b8 + offset; } /* - Internal function for setting array elements: + Internal function for setting array elements: - (si:aset value array dim0 ... dimN) + (si:aset value array dim0 ... dimN) */ @(defun si::aset (x &rest dims) @ { - cl_index i, j; - cl_index r = narg - 2; - cl_object v; - switch (ecl_t_of(x)) { - case t_array: - if (ecl_unlikely(r != x->array.rank)) - FEerror("Wrong number of indices.", 0); - for (i = j = 0; i < r; i++) { - cl_index s = checked_index(@[si::aset], x, i, + cl_index i, j; + cl_index r = narg - 2; + cl_object v; + switch (ecl_t_of(x)) { + case t_array: + if (ecl_unlikely(r != x->array.rank)) + FEerror("Wrong number of indices.", 0); + for (i = j = 0; i < r; i++) { + cl_index s = checked_index(@[si::aset], x, i, ecl_va_arg(dims), x->array.dims[i]); - j = j*(x->array.dims[i]) + s; - } - break; - case t_vector: + j = j*(x->array.dims[i]) + s; + } + break; + case t_vector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - if (ecl_unlikely(r != 1)) - FEerror("Wrong number of indices.", 0); - j = checked_index(@[si::aset], x, -1, ecl_va_arg(dims), + case t_base_string: + case t_bitvector: + if (ecl_unlikely(r != 1)) + FEerror("Wrong number of indices.", 0); + j = checked_index(@[si::aset], x, -1, ecl_va_arg(dims), x->vector.dim); - break; - default: + break; + default: FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); - } - v = ecl_va_arg(dims); - @(return ecl_aset_unsafe(x, j, v)) + } + v = ecl_va_arg(dims); + @(return ecl_aset_unsafe(x, j, v)) } @) cl_object ecl_aset_unsafe(cl_object x, cl_index index, cl_object value) { - switch (x->array.elttype) { - case ecl_aet_object: - x->array.self.t[index] = value; - break; - case ecl_aet_bc: - /* INV: ecl_char_code() checks the type of `value' */ - x->base_string.self[index] = ecl_char_code(value); - break; + switch (x->array.elttype) { + case ecl_aet_object: + x->array.self.t[index] = value; + break; + case ecl_aet_bc: + /* INV: ecl_char_code() checks the type of `value' */ + x->base_string.self[index] = ecl_char_code(value); + break; #ifdef ECL_UNICODE - case ecl_aet_ch: - x->string.self[index] = ecl_char_code(value); - break; + case ecl_aet_ch: + x->string.self[index] = ecl_char_code(value); + break; #endif - case ecl_aet_bit: { - cl_fixnum i = ecl_to_bit(value); - index += x->vector.offset; - if (i == 0) - x->vector.self.bit[index/CHAR_BIT] &= ~(0200>>index%CHAR_BIT); - else - x->vector.self.bit[index/CHAR_BIT] |= 0200>>index%CHAR_BIT; - break; - } - case ecl_aet_fix: - x->array.self.fix[index] = ecl_to_fix(value); - break; - case ecl_aet_index: - x->array.self.index[index] = ecl_to_size(value); - break; - case ecl_aet_sf: - x->array.self.sf[index] = ecl_to_float(value); - break; - case ecl_aet_df: - x->array.self.df[index] = ecl_to_double(value); - break; - case ecl_aet_b8: - x->array.self.b8[index] = ecl_to_uint8_t(value); - break; - case ecl_aet_i8: - x->array.self.i8[index] = ecl_to_int8_t(value); - break; + case ecl_aet_bit: { + cl_fixnum i = ecl_to_bit(value); + index += x->vector.offset; + if (i == 0) + x->vector.self.bit[index/CHAR_BIT] &= ~(0200>>index%CHAR_BIT); + else + x->vector.self.bit[index/CHAR_BIT] |= 0200>>index%CHAR_BIT; + break; + } + case ecl_aet_fix: + x->array.self.fix[index] = ecl_to_fix(value); + break; + case ecl_aet_index: + x->array.self.index[index] = ecl_to_size(value); + break; + case ecl_aet_sf: + x->array.self.sf[index] = ecl_to_float(value); + break; + case ecl_aet_df: + x->array.self.df[index] = ecl_to_double(value); + break; + case ecl_aet_b8: + x->array.self.b8[index] = ecl_to_uint8_t(value); + break; + case ecl_aet_i8: + x->array.self.i8[index] = ecl_to_int8_t(value); + break; #ifdef ecl_uint16_t - case ecl_aet_b16: - x->array.self.b16[index] = ecl_to_uint16_t(value); - break; - case ecl_aet_i16: - x->array.self.i16[index] = ecl_to_int16_t(value); - break; + case ecl_aet_b16: + x->array.self.b16[index] = ecl_to_uint16_t(value); + break; + case ecl_aet_i16: + x->array.self.i16[index] = ecl_to_int16_t(value); + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - x->array.self.b32[index] = ecl_to_uint32_t(value); - break; - case ecl_aet_i32: - x->array.self.i32[index] = ecl_to_int32_t(value); - break; + case ecl_aet_b32: + x->array.self.b32[index] = ecl_to_uint32_t(value); + break; + case ecl_aet_i32: + x->array.self.i32[index] = ecl_to_int32_t(value); + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - x->array.self.b64[index] = ecl_to_uint64_t(value); - break; - case ecl_aet_i64: - x->array.self.i64[index] = ecl_to_int64_t(value); - break; + case ecl_aet_b64: + x->array.self.b64[index] = ecl_to_uint64_t(value); + break; + case ecl_aet_i64: + x->array.self.i64[index] = ecl_to_int64_t(value); + break; #endif - } - return(value); + } + return(value); } cl_object @@ -373,7 +373,7 @@ ecl_aset(cl_object x, cl_index index, cl_object value) FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); } if (ecl_unlikely(index >= x->array.dim)) { - out_of_bounds_error(index, x); + out_of_bounds_error(index, x); } return ecl_aset_unsafe(x, index, value); } @@ -385,47 +385,47 @@ ecl_aset1(cl_object x, cl_index index, cl_object value) FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]); } if (ecl_unlikely(index >= x->array.dim)) { - out_of_bounds_error(index, x); + out_of_bounds_error(index, x); } return ecl_aset_unsafe(x, index, value); } /* - Internal function for making arrays of more than one dimension: + Internal function for making arrays of more than one dimension: - (si:make-pure-array dimension-list element-type adjustable - displaced-to displaced-index-offset) + (si:make-pure-array dimension-list element-type adjustable + displaced-to displaced-index-offset) */ cl_object si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, - cl_object fillp, cl_object displ, cl_object disploff) + cl_object fillp, cl_object displ, cl_object disploff) { - cl_index r, s, i, j; - cl_object x; - if (ECL_FIXNUMP(dims)) { - return si_make_vector(etype, dims, adj, fillp, displ, disploff); - } else if (ecl_unlikely(!ECL_LISTP(dims))) { + cl_index r, s, i, j; + cl_object x; + if (ECL_FIXNUMP(dims)) { + return si_make_vector(etype, dims, adj, fillp, displ, disploff); + } else if (ecl_unlikely(!ECL_LISTP(dims))) { FEwrong_type_nth_arg(@[make-array], 1, dims, cl_list(3, @'or', @'list', @'fixnum')); } - r = ecl_length(dims); - if (ecl_unlikely(r >= ECL_ARRAY_RANK_LIMIT)) { - FEerror("The array rank, ~R, is too large.", 1, ecl_make_fixnum(r)); - } else if (r == 1) { - return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp, - displ, disploff); - } else if (ecl_unlikely(!Null(fillp))) { - FEerror(":FILL-POINTER may not be specified for an array of rank ~D", - 1, ecl_make_fixnum(r)); - } - x = ecl_alloc_object(t_array); - x->array.displaced = ECL_NIL; - x->array.self.t = NULL; /* for GC sake */ - x->array.rank = r; - x->array.elttype = (short)ecl_symbol_to_elttype(etype); - x->array.flags = 0; /* no fill pointer, no adjustable */ - x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); - for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) { + r = ecl_length(dims); + if (ecl_unlikely(r >= ECL_ARRAY_RANK_LIMIT)) { + FEerror("The array rank, ~R, is too large.", 1, ecl_make_fixnum(r)); + } else if (r == 1) { + return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp, + displ, disploff); + } else if (ecl_unlikely(!Null(fillp))) { + FEerror(":FILL-POINTER may not be specified for an array of rank ~D", + 1, ecl_make_fixnum(r)); + } + x = ecl_alloc_object(t_array); + x->array.displaced = ECL_NIL; + x->array.self.t = NULL; /* for GC sake */ + x->array.rank = r; + x->array.elttype = (short)ecl_symbol_to_elttype(etype); + x->array.flags = 0; /* no fill pointer, no adjustable */ + x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); + for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) { cl_object d = ECL_CONS_CAR(dims); if (ecl_unlikely(!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || @@ -436,40 +436,40 @@ si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, FEwrong_type_nth_arg(@[make-array], 1, d, type); } j = ecl_fixnum(d); - s *= (x->array.dims[i] = j); - if (ecl_unlikely(s > ECL_ARRAY_TOTAL_LIMIT)) { + s *= (x->array.dims[i] = j); + if (ecl_unlikely(s > ECL_ARRAY_TOTAL_LIMIT)) { cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)); FEwrong_type_key_arg(@[make-array], @[array-total-size], ecl_make_fixnum(s), type); } - } - x->array.dim = s; + } + x->array.dim = s; if (adj != ECL_NIL) { x->array.flags |= ECL_FLAG_ADJUSTABLE; } - if (Null(displ)) - ecl_array_allocself(x); - else - ecl_displace(x, displ, disploff); - @(return x); + if (Null(displ)) + ecl_array_allocself(x); + else + ecl_displace(x, displ, disploff); + @(return x); } /* - Internal function for making vectors: + Internal function for making vectors: - (si:make-vector element-type dimension adjustable fill-pointer - displaced-to displaced-index-offset) + (si:make-vector element-type dimension adjustable fill-pointer + displaced-to displaced-index-offset) */ cl_object si_make_vector(cl_object etype, cl_object dim, cl_object adj, - cl_object fillp, cl_object displ, cl_object disploff) + cl_object fillp, cl_object displ, cl_object disploff) { - cl_index d, f; - cl_object x; - cl_elttype aet; + cl_index d, f; + cl_object x; + cl_elttype aet; AGAIN: - aet = ecl_symbol_to_elttype(etype); + aet = ecl_symbol_to_elttype(etype); if (ecl_unlikely(!ECL_FIXNUMP(dim) || ecl_fixnum_minusp(dim) || ecl_fixnum_greater(dim, ECL_ARRAY_DIMENSION_LIMIT))) { cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), @@ -477,50 +477,50 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj, FEwrong_type_nth_arg(@[make-array], 1, dim, type); } d = ecl_fixnum(dim); - if (aet == ecl_aet_bc) { - x = ecl_alloc_object(t_base_string); + if (aet == ecl_aet_bc) { + x = ecl_alloc_object(t_base_string); x->base_string.elttype = (short)aet; - } else if (aet == ecl_aet_bit) { - x = ecl_alloc_object(t_bitvector); + } else if (aet == ecl_aet_bit) { + x = ecl_alloc_object(t_bitvector); x->vector.elttype = (short)aet; #ifdef ECL_UNICODE - } else if (aet == ecl_aet_ch) { - x = ecl_alloc_object(t_string); + } else if (aet == ecl_aet_ch) { + x = ecl_alloc_object(t_string); x->string.elttype = (short)aet; #endif - } else { - x = ecl_alloc_object(t_vector); - x->vector.elttype = (short)aet; - } - x->vector.self.t = NULL; /* for GC sake */ - x->vector.displaced = ECL_NIL; - x->vector.dim = d; + } else { + x = ecl_alloc_object(t_vector); + x->vector.elttype = (short)aet; + } + x->vector.self.t = NULL; /* for GC sake */ + x->vector.displaced = ECL_NIL; + x->vector.dim = d; x->vector.flags = 0; if (adj != ECL_NIL) { x->vector.flags |= ECL_FLAG_ADJUSTABLE; } - if (Null(fillp)) { - f = d; - } else if (fillp == ECL_T) { - x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; - f = d; - } else if (ECL_FIXNUMP(fillp) && ecl_fixnum_geq(fillp,ecl_make_fixnum(0)) && - ((f = ecl_fixnum(fillp)) <= d)) { - x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; - } else { - fillp = ecl_type_error(@'make-array',"fill pointer",fillp, - cl_list(3,@'or',cl_list(3,@'member',ECL_NIL,ECL_T), - cl_list(3,@'integer',ecl_make_fixnum(0), - dim))); - goto AGAIN; - } - x->vector.fillp = f; + if (Null(fillp)) { + f = d; + } else if (fillp == ECL_T) { + x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; + f = d; + } else if (ECL_FIXNUMP(fillp) && ecl_fixnum_geq(fillp,ecl_make_fixnum(0)) && + ((f = ecl_fixnum(fillp)) <= d)) { + x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER; + } else { + fillp = ecl_type_error(@'make-array',"fill pointer",fillp, + cl_list(3,@'or',cl_list(3,@'member',ECL_NIL,ECL_T), + cl_list(3,@'integer',ecl_make_fixnum(0), + dim))); + goto AGAIN; + } + x->vector.fillp = f; - if (Null(displ)) - ecl_array_allocself(x); - else - ecl_displace(x, displ, disploff); - @(return x) + if (Null(displ)) + ecl_array_allocself(x); + else + ecl_displace(x, displ, disploff); + @(return x) } cl_object * @@ -537,28 +537,28 @@ void ecl_array_allocself(cl_object x) { cl_elttype t = x->array.elttype; - cl_index d = x->array.dim; - switch (t) { - /* assign self field only after it has been filled, for GC sake */ - case ecl_aet_object: - x->array.self.t = alloc_pointerfull_memory(d); - return; + cl_index d = x->array.dim; + switch (t) { + /* assign self field only after it has been filled, for GC sake */ + case ecl_aet_object: + x->array.self.t = alloc_pointerfull_memory(d); + return; #ifdef ECL_UNICODE - case ecl_aet_ch: { - ecl_character *elts; + case ecl_aet_ch: { + ecl_character *elts; d *= sizeof(ecl_character); - elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character)); - x->string.self = elts; - return; + elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character)); + x->string.self = elts; + return; } #endif - case ecl_aet_bc: { - cl_index elt_size = 1; - x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic(d+1); - /* Null terminate the string */ - x->vector.self.bc[d] = 0; - break; - } + case ecl_aet_bc: { + cl_index elt_size = 1; + x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic(d+1); + /* Null terminate the string */ + x->vector.self.bc[d] = 0; + break; + } case ecl_aet_bit: d = (d + (CHAR_BIT-1)) / CHAR_BIT; x->vector.self.bit = (byte *)ecl_alloc_atomic(d); @@ -575,16 +575,16 @@ ecl_array_allocself(cl_object x) cl_object ecl_alloc_simple_vector(cl_index l, cl_elttype aet) { - cl_object x; + cl_object x; - switch (aet) { - case ecl_aet_bc: + switch (aet) { + case ecl_aet_bc: x = ecl_alloc_compact_object(t_base_string, l+1); x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x); - x->base_string.self[l] = 0; + x->base_string.self[l] = 0; break; #ifdef ECL_UNICODE - case ecl_aet_ch: + case ecl_aet_ch: { cl_index bytes = sizeof(ecl_character) * l; x = ecl_alloc_compact_object(t_string, bytes); @@ -592,86 +592,86 @@ ecl_alloc_simple_vector(cl_index l, cl_elttype aet) } break; #endif - case ecl_aet_bit: + case ecl_aet_bit: { cl_index bytes = (l + (CHAR_BIT-1))/CHAR_BIT; x = ecl_alloc_compact_object(t_bitvector, bytes); x->vector.self.bit = ECL_COMPACT_OBJECT_EXTRA(x); - x->vector.offset = 0; + x->vector.offset = 0; } - break; + break; case ecl_aet_object: { - x = ecl_alloc_object(t_vector); + x = ecl_alloc_object(t_vector); x->vector.self.t = alloc_pointerfull_memory(l); } break; - default: - x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]); + default: + x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]); x->vector.self.bc = ECL_COMPACT_OBJECT_EXTRA(x); - } + } x->base_string.elttype = aet; x->base_string.flags = 0; /* no fill pointer, not adjustable */ x->base_string.displaced = ECL_NIL; x->base_string.dim = x->base_string.fillp = l; - return x; + return x; } cl_elttype ecl_symbol_to_elttype(cl_object x) { BEGIN: - if (x == @'base-char') - return(ecl_aet_bc); + if (x == @'base-char') + return(ecl_aet_bc); #ifdef ECL_UNICODE - if (x == @'character') - return(ecl_aet_ch); + if (x == @'character') + return(ecl_aet_ch); #endif - else if (x == @'bit') - return(ecl_aet_bit); - else if (x == @'ext::cl-fixnum') - return(ecl_aet_fix); - else if (x == @'ext::cl-index') - return(ecl_aet_index); - else if (x == @'single-float' || x == @'short-float') - return(ecl_aet_sf); - else if (x == @'double-float') - return(ecl_aet_df); - else if (x == @'long-float') { + else if (x == @'bit') + return(ecl_aet_bit); + else if (x == @'ext::cl-fixnum') + return(ecl_aet_fix); + else if (x == @'ext::cl-index') + return(ecl_aet_index); + else if (x == @'single-float' || x == @'short-float') + return(ecl_aet_sf); + else if (x == @'double-float') + return(ecl_aet_df); + else if (x == @'long-float') { #ifdef ECL_LONG_FLOAT - return(ecl_aet_object); + return(ecl_aet_object); #else - return(ecl_aet_df); + return(ecl_aet_df); #endif - } else if (x == @'ext::byte8') - return(ecl_aet_b8); - else if (x == @'ext::integer8') - return(ecl_aet_i8); + } else if (x == @'ext::byte8') + return(ecl_aet_b8); + else if (x == @'ext::integer8') + return(ecl_aet_i8); #ifdef ecl_uint16_t - else if (x == @'ext::byte16') - return(ecl_aet_b16); - else if (x == @'ext::integer16') - return(ecl_aet_i16); + else if (x == @'ext::byte16') + return(ecl_aet_b16); + else if (x == @'ext::integer16') + return(ecl_aet_i16); #endif #ifdef ecl_uint32_t - else if (x == @'ext::byte32') - return(ecl_aet_b32); - else if (x == @'ext::integer32') - return(ecl_aet_i32); + else if (x == @'ext::byte32') + return(ecl_aet_b32); + else if (x == @'ext::integer32') + return(ecl_aet_i32); #endif #ifdef ecl_uint64_t - else if (x == @'ext::byte64') - return(ecl_aet_b64); - else if (x == @'ext::integer64') - return(ecl_aet_i64); + else if (x == @'ext::byte64') + return(ecl_aet_b64); + else if (x == @'ext::integer64') + return(ecl_aet_i64); #endif - else if (x == @'t') - return(ecl_aet_object); - else if (x == ECL_NIL) { - FEerror("ECL does not support arrays with element type NIL", 0); - } - x = cl_upgraded_array_element_type(1, x); - goto BEGIN; + else if (x == @'t') + return(ecl_aet_object); + else if (x == ECL_NIL) { + FEerror("ECL does not support arrays with element type NIL", 0); + } + x = cl_upgraded_array_element_type(1, x); + goto BEGIN; } cl_object @@ -685,98 +685,98 @@ si_array_element_type_byte_size(cl_object type) { cl_elttype aet = ECL_ARRAYP(type) ? type->array.elttype : ecl_symbol_to_elttype(type); - cl_object size = ecl_make_fixnum(ecl_aet_size[aet]); - if (aet == ecl_aet_bit) - size = ecl_make_ratio(ecl_make_fixnum(1),ecl_make_fixnum(CHAR_BIT)); - @(return size ecl_elttype_to_symbol(aet)) + cl_object size = ecl_make_fixnum(ecl_aet_size[aet]); + if (aet == ecl_aet_bit) + size = ecl_make_ratio(ecl_make_fixnum(1),ecl_make_fixnum(CHAR_BIT)); + @(return size ecl_elttype_to_symbol(aet)) } static void * address_inc(void *address, cl_fixnum inc, cl_elttype elt_type) { - union ecl_array_data aux; - aux.t = address; - switch (elt_type) { - case ecl_aet_object: - return aux.t + inc; - case ecl_aet_fix: - return aux.fix + inc; - case ecl_aet_index: - return aux.fix + inc; - case ecl_aet_sf: - return aux.sf + inc; - case ecl_aet_bc: - return aux.bc + inc; + union ecl_array_data aux; + aux.t = address; + switch (elt_type) { + case ecl_aet_object: + return aux.t + inc; + case ecl_aet_fix: + return aux.fix + inc; + case ecl_aet_index: + return aux.fix + inc; + case ecl_aet_sf: + return aux.sf + inc; + case ecl_aet_bc: + return aux.bc + inc; #ifdef ECL_UNICODE - case ecl_aet_ch: + case ecl_aet_ch: return aux.c + inc; #endif - case ecl_aet_df: - return aux.df + inc; - case ecl_aet_b8: - case ecl_aet_i8: - return aux.b8 + inc; + case ecl_aet_df: + return aux.df + inc; + case ecl_aet_b8: + case ecl_aet_i8: + return aux.b8 + inc; #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: - return aux.b16 + inc; + case ecl_aet_b16: + case ecl_aet_i16: + return aux.b16 + inc; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: - return aux.b32 + inc; + case ecl_aet_b32: + case ecl_aet_i32: + return aux.b32 + inc; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: - return aux.b64 + inc; + case ecl_aet_b64: + case ecl_aet_i64: + return aux.b64 + inc; #endif - default: - FEbad_aet(); - } + default: + FEbad_aet(); + } } cl_object cl_array_element_type(cl_object a) { - @(return ecl_elttype_to_symbol(ecl_array_elttype(a))) + @(return ecl_elttype_to_symbol(ecl_array_elttype(a))) } /* - Displace(from, to, offset) displaces the from-array - to the to-array (the original array) by the specified offset. - It changes the a_displaced field of both arrays. - The field is a cons; the car of the from-array points to - the to-array and the cdr of the to-array is a list of arrays - displaced to the to-array, so the from-array is pushed to the - cdr of the to-array's array.displaced. + Displace(from, to, offset) displaces the from-array + to the to-array (the original array) by the specified offset. + It changes the a_displaced field of both arrays. + The field is a cons; the car of the from-array points to + the to-array and the cdr of the to-array is a list of arrays + displaced to the to-array, so the from-array is pushed to the + cdr of the to-array's array.displaced. */ void ecl_displace(cl_object from, cl_object to, cl_object offset) { - cl_index j; - void *base; - cl_elttype totype, fromtype; - fromtype = from->array.elttype; + cl_index j; + void *base; + cl_elttype totype, fromtype; + fromtype = from->array.elttype; if (ecl_unlikely(!ECL_FIXNUMP(offset) || ((j = ecl_fixnum(offset)) < 0))) { FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], offset, @[fixnum]); } - if (ecl_t_of(to) == t_foreign) { - if (fromtype == ecl_aet_bit || fromtype == ecl_aet_object) { - FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0); - } - base = to->foreign.data; - from->array.displaced = to; - } else { + if (ecl_t_of(to) == t_foreign) { + if (fromtype == ecl_aet_bit || fromtype == ecl_aet_object) { + FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0); + } + base = to->foreign.data; + from->array.displaced = to; + } else { cl_fixnum maxdim; - totype = to->array.elttype; - if (totype != fromtype) - FEerror("Cannot displace the array, " + totype = to->array.elttype; + if (totype != fromtype) + FEerror("Cannot displace the array, " "because the element types don't match.", 0); maxdim = to->array.dim - from->array.dim; - if (maxdim < 0) - FEerror("Cannot displace the array, " + if (maxdim < 0) + FEerror("Cannot displace the array, " "because the total size of the to-array" "is too small.", 0); if (j > maxdim) { @@ -785,26 +785,26 @@ ecl_displace(cl_object from, cl_object to, cl_object offset) FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset], offset, type); } - from->array.displaced = ecl_list1(to); - /* We only need to keep track of the arrays that displace to us - * when this one array is adjustable */ - if (ECL_ADJUSTABLE_ARRAY_P(to)) { - cl_object track_list = to->array.displaced; - if (Null(track_list)) - to->array.displaced = - track_list = ecl_list1(ECL_NIL); - ECL_RPLACD(track_list, - CONS(from, ECL_CONS_CDR(track_list))); - } - if (fromtype == ecl_aet_bit) { - j += to->vector.offset; - from->vector.offset = j%CHAR_BIT; - from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; - return; - } - base = to->array.self.t; - } - from->array.self.t = address_inc(base, j, fromtype); + from->array.displaced = ecl_list1(to); + /* We only need to keep track of the arrays that displace to us + * when this one array is adjustable */ + if (ECL_ADJUSTABLE_ARRAY_P(to)) { + cl_object track_list = to->array.displaced; + if (Null(track_list)) + to->array.displaced = + track_list = ecl_list1(ECL_NIL); + ECL_RPLACD(track_list, + CONS(from, ECL_CONS_CDR(track_list))); + } + if (fromtype == ecl_aet_bit) { + j += to->vector.offset; + from->vector.offset = j%CHAR_BIT; + from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT; + return; + } + base = to->array.self.t; + } + from->array.self.t = address_inc(base, j, fromtype); } cl_object @@ -821,25 +821,25 @@ si_array_raw_data(cl_object x) data = x->vector.self.b8; to_array = x->array.displaced; if (to_array == ECL_NIL || ((to_array = ECL_CONS_CAR(to_array)) == ECL_NIL)) { - cl_index used_size = total_size; - int flags = 0; - if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { - used_size = x->vector.fillp * ecl_aet_size[et]; - flags = ECL_FLAG_HAS_FILL_POINTER; - } + cl_index used_size = total_size; + int flags = 0; + if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { + used_size = x->vector.fillp * ecl_aet_size[et]; + flags = ECL_FLAG_HAS_FILL_POINTER; + } output = ecl_alloc_object(t_vector); output->vector.elttype = ecl_aet_b8; output->vector.self.b8 = data; output->vector.dim = total_size; - output->vector.fillp = used_size; + output->vector.fillp = used_size; output->vector.flags = flags; output->vector.displaced = ECL_NIL; } else { cl_index displ = data - to_array->vector.self.b8; - cl_object fillp = ECL_NIL; - if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { - fillp = ecl_make_fixnum(x->vector.fillp * ecl_aet_size[et]); - } + cl_object fillp = ECL_NIL; + if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) { + fillp = ecl_make_fixnum(x->vector.fillp * ecl_aet_size[et]); + } output = si_make_vector(@'ext::byte8', ecl_make_fixnum(total_size), ECL_NIL, @@ -861,54 +861,54 @@ ecl_array_elttype(cl_object x) cl_object cl_array_rank(cl_object a) { - @(return ecl_make_fixnum(ecl_array_rank(a))) + @(return ecl_make_fixnum(ecl_array_rank(a))) } cl_index ecl_array_rank(cl_object a) { - switch (ecl_t_of(a)) { - case t_array: - return a->array.rank; + switch (ecl_t_of(a)) { + case t_array: + return a->array.rank; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: + case t_base_string: + case t_vector: + case t_bitvector: return 1; - default: + default: FEwrong_type_only_arg(@[array-dimension], a, @[array]); - } + } } cl_object cl_array_dimension(cl_object a, cl_object index) { - @(return ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index)))) + @(return ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index)))) } cl_index ecl_array_dimension(cl_object a, cl_index index) { - switch (ecl_t_of(a)) { - case t_array: { + switch (ecl_t_of(a)) { + case t_array: { if (ecl_unlikely(index > a->array.rank)) FEwrong_dimensions(a, index+1); - return a->array.dims[index]; - } + return a->array.dims[index]; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: + case t_base_string: + case t_vector: + case t_bitvector: if (ecl_unlikely(index)) FEwrong_dimensions(a, index+1); - return a->vector.dim; - default: + return a->vector.dim; + default: FEwrong_type_only_arg(@[array-dimension], a, @[array]); - } + } } cl_object @@ -916,7 +916,7 @@ cl_array_total_size(cl_object a) { if (ecl_unlikely(!ECL_ARRAYP(a))) FEwrong_type_only_arg(@[array-total-size], a, @[array]); - @(return ecl_make_fixnum(a->array.dim)) + @(return ecl_make_fixnum(a->array.dim)) } cl_object @@ -924,165 +924,165 @@ cl_adjustable_array_p(cl_object a) { if (ecl_unlikely(!ECL_ARRAYP(a))) FEwrong_type_only_arg(@[adjustable-array-p], a, @[array]); - @(return (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL)) + @(return (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL)) } /* - Internal function for checking if an array is displaced. + Internal function for checking if an array is displaced. */ cl_object cl_array_displacement(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object to_array; - cl_index offset; + const cl_env_ptr the_env = ecl_process_env(); + cl_object to_array; + cl_index offset; if (ecl_unlikely(!ECL_ARRAYP(a))) FEwrong_type_only_arg(@[array-displacement], a, @[array]); - to_array = a->array.displaced; - if (Null(to_array)) { - offset = 0; - } else if (Null(to_array = CAR(a->array.displaced))) { - offset = 0; - } else { - switch (a->array.elttype) { - case ecl_aet_object: - offset = a->array.self.t - to_array->array.self.t; - break; - case ecl_aet_bc: - offset = a->array.self.bc - to_array->array.self.bc; - break; + to_array = a->array.displaced; + if (Null(to_array)) { + offset = 0; + } else if (Null(to_array = CAR(a->array.displaced))) { + offset = 0; + } else { + switch (a->array.elttype) { + case ecl_aet_object: + offset = a->array.self.t - to_array->array.self.t; + break; + case ecl_aet_bc: + offset = a->array.self.bc - to_array->array.self.bc; + break; #ifdef ECL_UNICODE - case ecl_aet_ch: - offset = a->array.self.c - to_array->array.self.c; - break; + case ecl_aet_ch: + offset = a->array.self.c - to_array->array.self.c; + break; #endif - case ecl_aet_bit: - offset = a->array.self.bit - to_array->array.self.bit; - offset = offset * CHAR_BIT + a->array.offset - - to_array->array.offset; - break; - case ecl_aet_fix: - offset = a->array.self.fix - to_array->array.self.fix; - break; - case ecl_aet_index: - offset = a->array.self.fix - to_array->array.self.fix; - break; - case ecl_aet_sf: - offset = a->array.self.sf - to_array->array.self.sf; - break; - case ecl_aet_df: - offset = a->array.self.df - to_array->array.self.df; - break; - case ecl_aet_b8: - case ecl_aet_i8: - offset = a->array.self.b8 - to_array->array.self.b8; - break; + case ecl_aet_bit: + offset = a->array.self.bit - to_array->array.self.bit; + offset = offset * CHAR_BIT + a->array.offset + - to_array->array.offset; + break; + case ecl_aet_fix: + offset = a->array.self.fix - to_array->array.self.fix; + break; + case ecl_aet_index: + offset = a->array.self.fix - to_array->array.self.fix; + break; + case ecl_aet_sf: + offset = a->array.self.sf - to_array->array.self.sf; + break; + case ecl_aet_df: + offset = a->array.self.df - to_array->array.self.df; + break; + case ecl_aet_b8: + case ecl_aet_i8: + offset = a->array.self.b8 - to_array->array.self.b8; + break; #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: - offset = a->array.self.b16 - to_array->array.self.b16; - break; + case ecl_aet_b16: + case ecl_aet_i16: + offset = a->array.self.b16 - to_array->array.self.b16; + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: - offset = a->array.self.b32 - to_array->array.self.b32; - break; + case ecl_aet_b32: + case ecl_aet_i32: + offset = a->array.self.b32 - to_array->array.self.b32; + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: - offset = a->array.self.b64 - to_array->array.self.b64; - break; + case ecl_aet_b64: + case ecl_aet_i64: + offset = a->array.self.b64 - to_array->array.self.b64; + break; #endif - default: - FEbad_aet(); - } - } - ecl_return2(the_env, to_array, ecl_make_fixnum(offset)); + default: + FEbad_aet(); + } + } + ecl_return2(the_env, to_array, ecl_make_fixnum(offset)); } cl_object cl_svref(cl_object x, cl_object index) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index i; + const cl_env_ptr the_env = ecl_process_env(); + cl_index i; - if (ecl_unlikely(ecl_t_of(x) != t_vector || + if (ecl_unlikely(ecl_t_of(x) != t_vector || (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || CAR(x->vector.displaced) != ECL_NIL || (cl_elttype)x->vector.elttype != ecl_aet_object)) - { + { FEwrong_type_nth_arg(@[svref],1,x,@[simple-vector]); - } + } i = checked_index(@[svref], x, -1, index, x->vector.dim); - ecl_return1(the_env, x->vector.self.t[i]); + ecl_return1(the_env, x->vector.self.t[i]); } cl_object si_svset(cl_object x, cl_object index, cl_object v) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index i; + const cl_env_ptr the_env = ecl_process_env(); + cl_index i; - if (ecl_unlikely(ecl_t_of(x) != t_vector || + if (ecl_unlikely(ecl_t_of(x) != t_vector || (x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) || CAR(x->vector.displaced) != ECL_NIL || (cl_elttype)x->vector.elttype != ecl_aet_object)) - { - FEwrong_type_nth_arg(@[si::svset],1,x,@[simple-vector]); - } + { + FEwrong_type_nth_arg(@[si::svset],1,x,@[simple-vector]); + } i = checked_index(@[svref], x, -1, index, x->vector.dim); - ecl_return1(the_env, x->vector.self.t[i] = v); + ecl_return1(the_env, x->vector.self.t[i] = v); } cl_object cl_array_has_fill_pointer_p(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; - switch (ecl_t_of(a)) { - case t_array: - r = ECL_NIL; break; - case t_vector: - case t_bitvector: + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; + switch (ecl_t_of(a)) { + case t_array: + r = ECL_NIL; break; + case t_vector: + case t_bitvector: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? ECL_T : ECL_NIL; - break; - default: + case t_base_string: + r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? ECL_T : ECL_NIL; + break; + default: FEwrong_type_nth_arg(@[array-has-fill-pointer-p],1,a,@[array]); - } - ecl_return1(the_env, r); + } + ecl_return1(the_env, r); } cl_object cl_fill_pointer(cl_object a) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); if (ecl_unlikely(!ECL_VECTORP(a))) FEwrong_type_only_arg(@[fill-pointer], a, @[vector]); - if (ecl_unlikely(!ECL_ARRAY_HAS_FILL_POINTER_P(a))) { + if (ecl_unlikely(!ECL_ARRAY_HAS_FILL_POINTER_P(a))) { const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; - FEwrong_type_nth_arg(@[fill-pointer], 1, a, ecl_read_from_cstring(type)); - } - ecl_return1(the_env, ecl_make_fixnum(a->vector.fillp)); + FEwrong_type_nth_arg(@[fill-pointer], 1, a, ecl_read_from_cstring(type)); + } + ecl_return1(the_env, ecl_make_fixnum(a->vector.fillp)); } /* - Internal function for setting fill pointer. + Internal function for setting fill pointer. */ cl_object si_fill_pointer_set(cl_object a, cl_object fp) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_fixnum i; if (ecl_unlikely(!ECL_VECTORP(a) || !ECL_ARRAY_HAS_FILL_POINTER_P(a))) { const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"; - FEwrong_type_nth_arg(@[adjust-array], 1, a, + FEwrong_type_nth_arg(@[adjust-array], 1, a, ecl_read_from_cstring(type)); } if (ecl_unlikely(!ECL_FIXNUMP(fp) || ((i = ecl_fixnum(fp)) < 0) || @@ -1092,68 +1092,68 @@ si_fill_pointer_set(cl_object a, cl_object fp) FEwrong_type_key_arg(@[adjust-array], @[:fill-pointer], fp, type); } a->vector.fillp = i; - ecl_return1(the_env, fp); + ecl_return1(the_env, fp); } /* - Internal function for replacing the contents of arrays: + Internal function for replacing the contents of arrays: - (si:replace-array old-array new-array). + (si:replace-array old-array new-array). - Used in ADJUST-ARRAY. + Used in ADJUST-ARRAY. */ cl_object si_replace_array(cl_object olda, cl_object newa) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object dlist; - if (ecl_t_of(olda) != ecl_t_of(newa) - || (ecl_t_of(olda) == t_array && olda->array.rank != newa->array.rank)) - goto CANNOT; - if (!ECL_ADJUSTABLE_ARRAY_P(olda)) { - /* When an array is not adjustable, we simply output the new array */ - olda = newa; - goto OUTPUT; - } - for (dlist = CDR(olda->array.displaced); dlist != ECL_NIL; dlist = CDR(dlist)) { - cl_object other_array = CAR(dlist); - cl_object offset; - cl_array_displacement(other_array); - offset = ecl_nth_value(the_env, 1); - ecl_displace(other_array, newa, offset); - } - switch (ecl_t_of(olda)) { - case t_array: - case t_vector: - case t_bitvector: - olda->array = newa->array; - break; + const cl_env_ptr the_env = ecl_process_env(); + cl_object dlist; + if (ecl_t_of(olda) != ecl_t_of(newa) + || (ecl_t_of(olda) == t_array && olda->array.rank != newa->array.rank)) + goto CANNOT; + if (!ECL_ADJUSTABLE_ARRAY_P(olda)) { + /* When an array is not adjustable, we simply output the new array */ + olda = newa; + goto OUTPUT; + } + for (dlist = CDR(olda->array.displaced); dlist != ECL_NIL; dlist = CDR(dlist)) { + cl_object other_array = CAR(dlist); + cl_object offset; + cl_array_displacement(other_array); + offset = ecl_nth_value(the_env, 1); + ecl_displace(other_array, newa, offset); + } + switch (ecl_t_of(olda)) { + case t_array: + case t_vector: + case t_bitvector: + olda->array = newa->array; + break; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - olda->base_string = newa->base_string; - break; - default: - CANNOT: - FEerror("Cannot replace the array ~S by the array ~S.", - 2, olda, newa); - } + case t_base_string: + olda->base_string = newa->base_string; + break; + default: + CANNOT: + FEerror("Cannot replace the array ~S by the array ~S.", + 2, olda, newa); + } OUTPUT: - ecl_return1(the_env, olda); + ecl_return1(the_env, olda); } void ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, - cl_index i1, cl_index l) + cl_index i1, cl_index l) { - cl_elttype t = ecl_array_elttype(dest); - if (i0 + l > dest->array.dim) { - l = dest->array.dim - i0; - } - if (i1 + l > orig->array.dim) { - l = orig->array.dim - i1; - } + cl_elttype t = ecl_array_elttype(dest); + if (i0 + l > dest->array.dim) { + l = dest->array.dim - i0; + } + if (i1 + l > orig->array.dim) { + l = orig->array.dim - i1; + } if (t != ecl_array_elttype(orig) || t == ecl_aet_bit) { if (dest == orig && i0 > i1) { for (i0 += l, i1 += l; l--; ) { @@ -1180,115 +1180,115 @@ ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, void ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1) { - cl_elttype t = ecl_array_elttype(x); - cl_index i, j; - if (x->array.dim == 0) { - return; - } - if (i1 >= x->array.dim) { - i1 = x->array.dim; - } - switch (t) { - case ecl_aet_object: - case ecl_aet_fix: - case ecl_aet_index: - for (i = i0, j = i1-1; i < j; i++, --j) { - cl_object y = x->vector.self.t[i]; - x->vector.self.t[i] = x->vector.self.t[j]; - x->vector.self.t[j] = y; - } - break; - case ecl_aet_sf: - for (i = i0, j = i1-1; i < j; i++, --j) { - float y = x->array.self.sf[i]; - x->array.self.sf[i] = x->array.self.sf[j]; - x->array.self.sf[j] = y; - } - break; - case ecl_aet_df: - for (i = i0, j = i1-1; i < j; i++, --j) { - double y = x->array.self.df[i]; - x->array.self.df[i] = x->array.self.df[j]; - x->array.self.df[j] = y; - } - break; - case ecl_aet_bc: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_base_char y = x->array.self.bc[i]; - x->array.self.bc[i] = x->array.self.bc[j]; + cl_elttype t = ecl_array_elttype(x); + cl_index i, j; + if (x->array.dim == 0) { + return; + } + if (i1 >= x->array.dim) { + i1 = x->array.dim; + } + switch (t) { + case ecl_aet_object: + case ecl_aet_fix: + case ecl_aet_index: + for (i = i0, j = i1-1; i < j; i++, --j) { + cl_object y = x->vector.self.t[i]; + x->vector.self.t[i] = x->vector.self.t[j]; + x->vector.self.t[j] = y; + } + break; + case ecl_aet_sf: + for (i = i0, j = i1-1; i < j; i++, --j) { + float y = x->array.self.sf[i]; + x->array.self.sf[i] = x->array.self.sf[j]; + x->array.self.sf[j] = y; + } + break; + case ecl_aet_df: + for (i = i0, j = i1-1; i < j; i++, --j) { + double y = x->array.self.df[i]; + x->array.self.df[i] = x->array.self.df[j]; + x->array.self.df[j] = y; + } + break; + case ecl_aet_bc: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_base_char y = x->array.self.bc[i]; + x->array.self.bc[i] = x->array.self.bc[j]; x->array.self.bc[j] = y; - } - break; - case ecl_aet_b8: + } + break; + case ecl_aet_b8: case ecl_aet_i8: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint8_t y = x->array.self.b8[i]; - x->array.self.b8[i] = x->array.self.b8[j]; - x->array.self.b8[j] = y; - } - break; + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint8_t y = x->array.self.b8[i]; + x->array.self.b8[i] = x->array.self.b8[j]; + x->array.self.b8[j] = y; + } + break; #ifdef ecl_uint16_t - case ecl_aet_b16: + case ecl_aet_b16: case ecl_aet_i16: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint16_t y = x->array.self.b16[i]; - x->array.self.b16[i] = x->array.self.b16[j]; - x->array.self.b16[j] = y; - } - break; + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint16_t y = x->array.self.b16[i]; + x->array.self.b16[i] = x->array.self.b16[j]; + x->array.self.b16[j] = y; + } + break; #endif #ifdef ecl_uint32_t - case ecl_aet_b32: + case ecl_aet_b32: case ecl_aet_i32: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint32_t y = x->array.self.b32[i]; - x->array.self.b32[i] = x->array.self.b32[j]; - x->array.self.b32[j] = y; - } - break; + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint32_t y = x->array.self.b32[i]; + x->array.self.b32[i] = x->array.self.b32[j]; + x->array.self.b32[j] = y; + } + break; #endif #ifdef ecl_uint64_t - case ecl_aet_b64: + case ecl_aet_b64: case ecl_aet_i64: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_uint64_t y = x->array.self.b64[i]; - x->array.self.b64[i] = x->array.self.b64[j]; - x->array.self.b64[j] = y; - } - break; + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_uint64_t y = x->array.self.b64[i]; + x->array.self.b64[i] = x->array.self.b64[j]; + x->array.self.b64[j] = y; + } + break; #endif #ifdef ECL_UNICODE - case ecl_aet_ch: - for (i = i0, j = i1-1; i < j; i++, --j) { - ecl_character y = x->array.self.c[i]; - x->array.self.c[i] = x->array.self.c[j]; + case ecl_aet_ch: + for (i = i0, j = i1-1; i < j; i++, --j) { + ecl_character y = x->array.self.c[i]; + x->array.self.c[i] = x->array.self.c[j]; x->array.self.c[j] = y; - } - break; + } + break; #endif - case ecl_aet_bit: - for (i = i0 + x->vector.offset, - j = i1 + x->vector.offset - 1; - i < j; - i++, --j) { - int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT); - if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT)) - x->array.self.bit[i/CHAR_BIT] - |= 0200>>i%CHAR_BIT; - else - x->array.self.bit[i/CHAR_BIT] - &= ~(0200>>i%CHAR_BIT); - if (k) - x->array.self.bit[j/CHAR_BIT] - |= 0200>>j%CHAR_BIT; - else - x->array.self.bit[j/CHAR_BIT] - &= ~(0200>>j%CHAR_BIT); - } - break; - default: - FEbad_aet(); - } + case ecl_aet_bit: + for (i = i0 + x->vector.offset, + j = i1 + x->vector.offset - 1; + i < j; + i++, --j) { + int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT); + if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT)) + x->array.self.bit[i/CHAR_BIT] + |= 0200>>i%CHAR_BIT; + else + x->array.self.bit[i/CHAR_BIT] + &= ~(0200>>i%CHAR_BIT); + if (k) + x->array.self.bit[j/CHAR_BIT] + |= 0200>>j%CHAR_BIT; + else + x->array.self.bit[j/CHAR_BIT] + &= ~(0200>>j%CHAR_BIT); + } + break; + default: + FEbad_aet(); + } } cl_object @@ -1304,124 +1304,124 @@ si_copy_subarray(cl_object dest, cl_object start0, cl_object si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object end) { - cl_elttype t = ecl_array_elttype(x); + cl_elttype t = ecl_array_elttype(x); cl_index first = ecl_to_size(start); cl_index last = Null(end)? x->array.dim : ecl_to_size(end); if (first >= last) { goto END; } - switch (t) { - case ecl_aet_object: { + switch (t) { + case ecl_aet_object: { cl_object *p = x->vector.self.t + first; - for (first = last - first; first; --first, ++p) { *p = elt; } - break; + for (first = last - first; first; --first, ++p) { *p = elt; } + break; } - case ecl_aet_bc: { + case ecl_aet_bc: { ecl_base_char e = ecl_char_code(elt); ecl_base_char *p = x->vector.self.bc + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #ifdef ECL_UNICODE - case ecl_aet_ch: { + case ecl_aet_ch: { ecl_character e = ecl_char_code(elt); ecl_character *p = x->vector.self.c + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #endif - case ecl_aet_fix: { + case ecl_aet_fix: { cl_fixnum e = ecl_to_fix(elt); cl_fixnum *p = x->vector.self.fix + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_index: { + case ecl_aet_index: { cl_index e = ecl_to_size(elt); cl_index *p = x->vector.self.index + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_sf: { + case ecl_aet_sf: { float e = ecl_to_float(elt); float *p = x->vector.self.sf + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_df: { + case ecl_aet_df: { double e = ecl_to_double(elt); double *p = x->vector.self.df + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_b8: { + case ecl_aet_b8: { uint8_t e = ecl_to_uint8_t(elt); uint8_t *p = x->vector.self.b8 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_i8: { + case ecl_aet_i8: { int8_t e = ecl_to_int8_t(elt); int8_t *p = x->vector.self.i8 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #ifdef ecl_uint16_t - case ecl_aet_b16: { + case ecl_aet_b16: { ecl_uint16_t e = ecl_to_uint16_t(elt); ecl_uint16_t *p = x->vector.self.b16 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_i16: { + case ecl_aet_i16: { ecl_int16_t e = ecl_to_int16_t(elt); ecl_int16_t *p = x->vector.self.i16 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #endif #ifdef ecl_uint32_t - case ecl_aet_b32: { + case ecl_aet_b32: { ecl_uint32_t e = ecl_to_uint32_t(elt); ecl_uint32_t *p = x->vector.self.b32 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_i32: { + case ecl_aet_i32: { ecl_int32_t e = ecl_to_int32_t(elt); ecl_int32_t *p = x->vector.self.i32 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #endif #ifdef ecl_uint64_t - case ecl_aet_b64: { + case ecl_aet_b64: { ecl_uint64_t e = ecl_to_uint64_t(elt); ecl_uint64_t *p = x->vector.self.b64 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } - case ecl_aet_i64: { + case ecl_aet_i64: { ecl_int64_t e = ecl_to_int64_t(elt); ecl_int64_t *p = x->vector.self.i64 + first; - for (first = last - first; first; --first, ++p) { *p = e; } - break; + for (first = last - first; first; --first, ++p) { *p = e; } + break; } #endif - case ecl_aet_bit: { + case ecl_aet_bit: { int i = ecl_to_bit(elt); - for (last -= first, first += x->vector.offset; last; --last, ++first) { + for (last -= first, first += x->vector.offset; last; --last, ++first) { int mask = 0200>>first%CHAR_BIT; if (i == 0) x->vector.self.bit[first/CHAR_BIT] &= ~mask; else x->vector.self.bit[first/CHAR_BIT] |= mask; - } - break; + } + break; + } + default: + FEbad_aet(); } - default: - FEbad_aet(); - } END: @(return x) } diff --git a/src/c/assignment.d b/src/c/assignment.d index 554eb2cbd..beb5bfed3 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -24,179 +24,179 @@ static void FEconstant_assignment(cl_object var) ecl_attr_noreturn; static void FEconstant_assignment(cl_object var) { - FEinvalid_variable("Cannot assign to the constant ~S.", var); + FEinvalid_variable("Cannot assign to the constant ~S.", var); } cl_object cl_set(cl_object var, cl_object value) { - const cl_env_ptr env = ecl_process_env(); - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - unlikely_if (var->symbol.stype & ecl_stp_constant) - FEconstant_assignment(var); - ecl_return1(env, ECL_SETQ(env, var, value)); + const cl_env_ptr env = ecl_process_env(); + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + unlikely_if (var->symbol.stype & ecl_stp_constant) + FEconstant_assignment(var); + ecl_return1(env, ECL_SETQ(env, var, value)); } cl_object ecl_setq(cl_env_ptr env, cl_object var, cl_object value) { - unlikely_if (Null(var)) { - FEconstant_assignment(var); - } - unlikely_if (ecl_t_of(var) != t_symbol) { - FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); - } - return ECL_SETQ(env, var, value); + unlikely_if (Null(var)) { + FEconstant_assignment(var); + } + unlikely_if (ecl_t_of(var) != t_symbol) { + FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]); + } + return ECL_SETQ(env, var, value); } static cl_object unbound_setf_function_error(cl_narg narg, ...) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object name = the_env->function->cclosure.env; - FEundefined_function(cl_list(2, @'setf', name)); + FEundefined_function(cl_list(2, @'setf', name)); } static cl_object make_setf_function_error(cl_object name) { - return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error, - name, ECL_NIL); + return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error, + name, ECL_NIL); } cl_object ecl_setf_definition(cl_object sym, cl_object createp) { - cl_env_ptr the_env = ecl_process_env(); - cl_object pair; + cl_env_ptr the_env = ecl_process_env(); + cl_object pair; ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (Null(pair) && !Null(createp)) { - createp = make_setf_function_error(sym); - pair = ecl_cons(createp, ECL_NIL); - ecl_sethash(sym, cl_core.setf_definitions, pair); - } + if (Null(pair) && !Null(createp)) { + createp = make_setf_function_error(sym); + pair = ecl_cons(createp, ECL_NIL); + ecl_sethash(sym, cl_core.setf_definitions, pair); + } } ECL_WITH_GLOBAL_ENV_RDLOCK_END; - return pair; + return pair; } cl_object si_setf_definition(cl_object sym, cl_object value) { - @(return ecl_setf_definition(sym, value)) + @(return ecl_setf_definition(sym, value)) } static void ecl_rem_setf_definition(cl_object sym) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { cl_object pair = ecl_gethash_safe(sym, cl_core.setf_definitions, ECL_NIL); - if (!Null(pair)) { - ECL_RPLACA(pair, make_setf_function_error(sym)); - ECL_RPLACD(pair, ECL_NIL); - /* - FIXME: This leaks resources - We actually cannot remove it, because some compiled - code might be using it! - ecl_remhash(sym, cl_core.setf_definitions); - */ - } + if (!Null(pair)) { + ECL_RPLACA(pair, make_setf_function_error(sym)); + ECL_RPLACD(pair, ECL_NIL); + /* + FIXME: This leaks resources + We actually cannot remove it, because some compiled + code might be using it! + ecl_remhash(sym, cl_core.setf_definitions); + */ + } } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } @(defun si::fset (fname def &optional macro pprint) - cl_object sym = si_function_block_name(fname); - cl_object pack; - bool mflag; - int type; + cl_object sym = si_function_block_name(fname); + cl_object pack; + bool mflag; + int type; @ - if (Null(cl_functionp(def))) - FEinvalid_function(def); - pack = ecl_symbol_package(sym); - if (pack != ECL_NIL && pack->pack.locked) { - CEpackage_error("Attempt to redefine function ~S in locked package.", - "Ignore lock and proceed", pack, 1, fname); - } - mflag = !Null(macro); - type = ecl_symbol_type(sym); - if ((type & ecl_stp_special_form) && !mflag) { - FEerror("Given that ~S is a special form, ~S cannot be defined as a function.", - 2, sym, fname); - } - if (ECL_SYMBOLP(fname)) { - if (mflag) { - type |= ecl_stp_macro; - } else { - type &= ~ecl_stp_macro; - } - ecl_symbol_type_set(sym, type); - ECL_SYM_FUN(sym) = def; - ecl_clear_compiler_properties(sym); + if (Null(cl_functionp(def))) + FEinvalid_function(def); + pack = ecl_symbol_package(sym); + if (pack != ECL_NIL && pack->pack.locked) { + CEpackage_error("Attempt to redefine function ~S in locked package.", + "Ignore lock and proceed", pack, 1, fname); + } + mflag = !Null(macro); + type = ecl_symbol_type(sym); + if ((type & ecl_stp_special_form) && !mflag) { + FEerror("Given that ~S is a special form, ~S cannot be defined as a function.", + 2, sym, fname); + } + if (ECL_SYMBOLP(fname)) { + if (mflag) { + type |= ecl_stp_macro; + } else { + type &= ~ecl_stp_macro; + } + ecl_symbol_type_set(sym, type); + ECL_SYM_FUN(sym) = def; + ecl_clear_compiler_properties(sym); #ifndef ECL_CMU_FORMAT - if (pprint == ECL_NIL) - si_rem_sysprop(sym, @'si::pretty-print-format'); - else - si_put_sysprop(sym, @'si::pretty-print-format', pprint); + if (pprint == ECL_NIL) + si_rem_sysprop(sym, @'si::pretty-print-format'); + else + si_put_sysprop(sym, @'si::pretty-print-format', pprint); #endif - } else if (mflag) { - FEerror("~S is not a valid name for a macro.", 1, fname); - } else { - cl_object pair = ecl_setf_definition(sym, def); - ECL_RPLACA(pair, def); - ECL_RPLACD(pair, sym); - } - @(return def) + } else if (mflag) { + FEerror("~S is not a valid name for a macro.", 1, fname); + } else { + cl_object pair = ecl_setf_definition(sym, def); + ECL_RPLACA(pair, def); + ECL_RPLACD(pair, sym); + } + @(return def) @) cl_object cl_makunbound(cl_object sym) { - if (ecl_symbol_type(sym) & ecl_stp_constant) - FEinvalid_variable("Cannot unbind the constant ~S.", sym); - /* FIXME! The semantics of MAKUNBOUND is not very clear with local - bindings ... */ - ECL_SET(sym, OBJNULL); - @(return sym) + if (ecl_symbol_type(sym) & ecl_stp_constant) + FEinvalid_variable("Cannot unbind the constant ~S.", sym); + /* FIXME! The semantics of MAKUNBOUND is not very clear with local + bindings ... */ + ECL_SET(sym, OBJNULL); + @(return sym) } cl_object cl_fmakunbound(cl_object fname) { - cl_object sym = si_function_block_name(fname); - cl_object pack = ecl_symbol_package(sym); - if (pack != ECL_NIL && pack->pack.locked) { - CEpackage_error("Attempt to redefine function ~S in locked package.", - "Ignore lock and proceed", pack, 1, fname); - } - if (ECL_SYMBOLP(fname)) { - ecl_clear_compiler_properties(sym); - ECL_SYM_FUN(sym) = ECL_NIL; - ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~ecl_stp_macro); - } else { - ecl_rem_setf_definition(sym); - si_rem_sysprop(sym, @'si::setf-method'); - } - @(return fname) + cl_object sym = si_function_block_name(fname); + cl_object pack = ecl_symbol_package(sym); + if (pack != ECL_NIL && pack->pack.locked) { + CEpackage_error("Attempt to redefine function ~S in locked package.", + "Ignore lock and proceed", pack, 1, fname); + } + if (ECL_SYMBOLP(fname)) { + ecl_clear_compiler_properties(sym); + ECL_SYM_FUN(sym) = ECL_NIL; + ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~ecl_stp_macro); + } else { + ecl_rem_setf_definition(sym); + si_rem_sysprop(sym, @'si::setf-method'); + } + @(return fname) } void ecl_clear_compiler_properties(cl_object sym) { - if (ecl_option_values[ECL_OPT_BOOTED]) { - funcall(2, @'si::clear-compiler-properties', sym); - } + if (ecl_option_values[ECL_OPT_BOOTED]) { + funcall(2, @'si::clear-compiler-properties', sym); + } } cl_object si_get_sysprop(cl_object sym, cl_object prop) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); prop = ecl_getf(plist, prop, OBJNULL); @@ -211,22 +211,22 @@ si_get_sysprop(cl_object sym, cl_object prop) cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); ecl_sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop)); } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return value); + @(return value); } cl_object si_rem_sysprop(cl_object sym, cl_object prop) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object plist, found; - plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); - plist = si_rem_f(plist, prop); - found = ecl_nth_value(the_env, 1); - ecl_sethash(sym, cl_core.system_properties, plist); - ecl_return1(the_env, found); + const cl_env_ptr the_env = ecl_process_env(); + cl_object plist, found; + plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL); + plist = si_rem_f(plist, prop); + found = ecl_nth_value(the_env, 1); + ecl_sethash(sym, cl_core.system_properties, plist); + ecl_return1(the_env, found); } diff --git a/src/c/backq.d b/src/c/backq.d index 6f7fcf092..4c9e10e42 100644 --- a/src/c/backq.d +++ b/src/c/backq.d @@ -20,12 +20,12 @@ /******************************* ------- ******************************/ -#define QUOTE 1 -#define EVAL 2 -#define LIST 3 -#define LISTX 4 -#define APPEND 5 -#define NCONC 6 +#define QUOTE 1 +#define EVAL 2 +#define LIST 3 +#define LISTX 4 +#define APPEND 5 +#define NCONC 6 extern int _cl_backq_car(cl_object *px); static cl_object backq(cl_object x); @@ -33,234 +33,234 @@ static cl_object backq(cl_object x); static cl_object kwote(cl_object x) { - cl_type t = ecl_t_of(x); - if ((t == t_symbol && !Null(x) && !ecl_keywordp(x)) || - t == t_list || t == t_vector) - x = CONS(@'quote', ecl_list1(x)); - return x; + cl_type t = ecl_t_of(x); + if ((t == t_symbol && !Null(x) && !ecl_keywordp(x)) || + t == t_list || t == t_vector) + x = CONS(@'quote', ecl_list1(x)); + return x; } /* - _cl_backq_cdr(&x) puts result into x and returns one of + _cl_backq_cdr(&x) puts result into x and returns one of - QUOTE the form should be quoted - EVAL the form should be evaluated - LIST the form should be applied to LIST - LISTX the form should be applied to LIST* - APPEND the form should be applied to APPEND - NCONC the form should be applied to NCONC + QUOTE the form should be quoted + EVAL the form should be evaluated + LIST the form should be applied to LIST + LISTX the form should be applied to LIST* + APPEND the form should be applied to APPEND + NCONC the form should be applied to NCONC */ static int _cl_backq_cdr(cl_object *px) { - cl_object x = *px, ax, dx; - int a, d, out; + cl_object x = *px, ax, dx; + int a, d, out; - if (ECL_ATOM(x)) - return(QUOTE); - if (CAR(x) == @'si::unquote') { - *px = CADR(x); - return(EVAL); - } - if (CAR(x) == @'si::unquote-splice' || CAR(x) == @'si::unquote-nsplice') - FEerror(",@@ or ,. has appeared in an illegal position.", 0); + if (ECL_ATOM(x)) + return(QUOTE); + if (CAR(x) == @'si::unquote') { + *px = CADR(x); + return(EVAL); + } + if (CAR(x) == @'si::unquote-splice' || CAR(x) == @'si::unquote-nsplice') + FEerror(",@@ or ,. has appeared in an illegal position.", 0); - ax = CAR(x); dx = CDR(x); - a = _cl_backq_car(&ax); - d = _cl_backq_cdr(&dx); - if (d == QUOTE) { - switch (a) { - case QUOTE: - return(QUOTE); + ax = CAR(x); dx = CDR(x); + a = _cl_backq_car(&ax); + d = _cl_backq_cdr(&dx); + if (d == QUOTE) { + switch (a) { + case QUOTE: + return(QUOTE); - case EVAL: - if (Null(dx)) { - out = LIST; - } else if (CONSP(dx) && Null(CDR(dx))) { - dx = ecl_list1(kwote(CAR(dx))); - out = LIST; - } else { - dx = ecl_list1(kwote(dx)); - out = LISTX; - } - break; - case APPEND: - case NCONC: - if (Null(dx)) { - *px = ax; - return EVAL; - } else { - dx = ecl_list1(kwote(dx)); - out = a; - } - break; - default: - ecl_internal_error("backquote botch"); - } - } else if (d == EVAL) { - switch (a) { - case QUOTE: - ax = kwote(ax); - dx = ecl_list1(dx); - out = LISTX; - break; - case EVAL: - dx = ecl_list1(dx); - out = LISTX; - break; - case APPEND: - case NCONC: - dx = ecl_list1(dx); - out = a; - break; - default: - ecl_internal_error("backquote botch"); - } - } else if (d == a) { - out = d; - } else { - switch (d) { - case LIST: - if (a == QUOTE) { - ax = kwote(ax); - out = LIST; - goto OUTPUT; - } else if (a == EVAL) { - out = LIST; - goto OUTPUT; - } - dx = CONS(@'list', dx); - break; - case LISTX: - if (a == QUOTE) { - ax = kwote(ax); - out = LISTX; - goto OUTPUT; - } else if (a == EVAL) { - out = LISTX; - goto OUTPUT; - } - dx = CONS(@'list*', dx); - break; - case APPEND: - dx = CONS(@'append', dx); - break; - case NCONC: - dx = CONS(@'nconc', dx); - break; - default: - ecl_internal_error("backquote botch"); - } - switch (a) { - case QUOTE: - ax = kwote(ax); - dx = ecl_list1(dx); - out = LISTX; - break; - case EVAL: - dx = ecl_list1(dx); - out = LISTX; - break; - case APPEND: - case NCONC: - dx = ecl_list1(dx); - out = a; - break; - default: - ecl_internal_error("backquote botch"); - } - } + case EVAL: + if (Null(dx)) { + out = LIST; + } else if (CONSP(dx) && Null(CDR(dx))) { + dx = ecl_list1(kwote(CAR(dx))); + out = LIST; + } else { + dx = ecl_list1(kwote(dx)); + out = LISTX; + } + break; + case APPEND: + case NCONC: + if (Null(dx)) { + *px = ax; + return EVAL; + } else { + dx = ecl_list1(kwote(dx)); + out = a; + } + break; + default: + ecl_internal_error("backquote botch"); + } + } else if (d == EVAL) { + switch (a) { + case QUOTE: + ax = kwote(ax); + dx = ecl_list1(dx); + out = LISTX; + break; + case EVAL: + dx = ecl_list1(dx); + out = LISTX; + break; + case APPEND: + case NCONC: + dx = ecl_list1(dx); + out = a; + break; + default: + ecl_internal_error("backquote botch"); + } + } else if (d == a) { + out = d; + } else { + switch (d) { + case LIST: + if (a == QUOTE) { + ax = kwote(ax); + out = LIST; + goto OUTPUT; + } else if (a == EVAL) { + out = LIST; + goto OUTPUT; + } + dx = CONS(@'list', dx); + break; + case LISTX: + if (a == QUOTE) { + ax = kwote(ax); + out = LISTX; + goto OUTPUT; + } else if (a == EVAL) { + out = LISTX; + goto OUTPUT; + } + dx = CONS(@'list*', dx); + break; + case APPEND: + dx = CONS(@'append', dx); + break; + case NCONC: + dx = CONS(@'nconc', dx); + break; + default: + ecl_internal_error("backquote botch"); + } + switch (a) { + case QUOTE: + ax = kwote(ax); + dx = ecl_list1(dx); + out = LISTX; + break; + case EVAL: + dx = ecl_list1(dx); + out = LISTX; + break; + case APPEND: + case NCONC: + dx = ecl_list1(dx); + out = a; + break; + default: + ecl_internal_error("backquote botch"); + } + } OUTPUT: - *px = CONS(ax, dx); - return out; + *px = CONS(ax, dx); + return out; } /* - _cl_backq_car(&x) puts result into x and returns one of + _cl_backq_car(&x) puts result into x and returns one of - QUOTE the form should be quoted - EVAL the form should be evaluated - APPEND the form should be appended - into the outer form - NCONC the form should be nconc'ed - into the outer form + QUOTE the form should be quoted + EVAL the form should be evaluated + APPEND the form should be appended + into the outer form + NCONC the form should be nconc'ed + into the outer form */ int _cl_backq_car(cl_object *px) { - cl_object x = *px; - int d; + cl_object x = *px; + int d; AGAIN: - if (ECL_ATOM(x)) - return(QUOTE); - if (CAR(x) == @'si::quasiquote') { - x = *px = backq(CADR(x)); - goto AGAIN; - } - if (CAR(x) == @'si::unquote') { - *px = CADR(x); - return EVAL; - } - if (CAR(x) == @'si::unquote-splice') { - *px = CADR(x); - return APPEND; - } - if (CAR(x) == @'si::unquote-nsplice') { - *px = CADR(x); - return NCONC; - } - d = _cl_backq_cdr(px); - switch (d) { - case QUOTE: - case EVAL: - return(d); + if (ECL_ATOM(x)) + return(QUOTE); + if (CAR(x) == @'si::quasiquote') { + x = *px = backq(CADR(x)); + goto AGAIN; + } + if (CAR(x) == @'si::unquote') { + *px = CADR(x); + return EVAL; + } + if (CAR(x) == @'si::unquote-splice') { + *px = CADR(x); + return APPEND; + } + if (CAR(x) == @'si::unquote-nsplice') { + *px = CADR(x); + return NCONC; + } + d = _cl_backq_cdr(px); + switch (d) { + case QUOTE: + case EVAL: + return(d); - case LIST: - *px = CONS(@'list', *px); - break; + case LIST: + *px = CONS(@'list', *px); + break; - case LISTX: - *px = CONS(@'list*', *px); - break; + case LISTX: + *px = CONS(@'list*', *px); + break; - case APPEND: - *px = CONS(@'append', *px); - break; + case APPEND: + *px = CONS(@'append', *px); + break; - case NCONC: - *px = CONS(@'nconc', *px); - break; + case NCONC: + *px = CONS(@'nconc', *px); + break; - default: - ecl_internal_error("backquote botch"); - } - return(EVAL); + default: + ecl_internal_error("backquote botch"); + } + return(EVAL); } static cl_object backq(cl_object x) { - int a; + int a; - a = _cl_backq_car(&x); - if (a == APPEND || a == NCONC) - FEerror(",@@ or ,. has appeared in an illegal position.", 0); - if (a == QUOTE) - return(kwote(x)); - return(x); + a = _cl_backq_car(&x); + if (a == APPEND || a == NCONC) + FEerror(",@@ or ,. has appeared in an illegal position.", 0); + if (a == QUOTE) + return(kwote(x)); + return(x); } static cl_object quasiquote_macro(cl_object whole, cl_object env) { - if (ecl_length(whole) != 2) { - FEprogram_error("Syntax error: ~S.", 1, whole); - } - @(return backq(CADR(whole))) + if (ecl_length(whole) != 2) { + FEprogram_error("Syntax error: ~S.", 1, whole); + } + @(return backq(CADR(whole))) } void init_backq(void) { - ecl_def_c_macro(@'si::quasiquote', quasiquote_macro, 2); + ecl_def_c_macro(@'si::quasiquote', quasiquote_macro, 2); } diff --git a/src/c/big.d b/src/c/big.d index 63af43428..6741138d7 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -66,43 +66,43 @@ _ecl_big_register_copy(cl_object old) { cl_object new_big = _ecl_big_copy(old); _ecl_big_register_free(old); - return new_big; + return new_big; } static cl_object big_normalize(cl_object x) { - int s = ECL_BIGNUM_SIZE(x); - if (s == 0) + int s = ECL_BIGNUM_SIZE(x); + if (s == 0) return(ecl_make_fixnum(0)); - if (s == 1) { + if (s == 1) { mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; if (y <= MOST_POSITIVE_FIXNUM) return ecl_make_fixnum(y); - } else if (s == -1) { + } else if (s == -1) { mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; if (y <= -MOST_NEGATIVE_FIXNUM) return ecl_make_fixnum(-y); - } - return x; + } + return x; } cl_object _ecl_big_register_normalize(cl_object x) { - int s = ECL_BIGNUM_SIZE(x); - if (s == 0) + int s = ECL_BIGNUM_SIZE(x); + if (s == 0) return(ecl_make_fixnum(0)); - if (s == 1) { + if (s == 1) { mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; if (y <= MOST_POSITIVE_FIXNUM) return ecl_make_fixnum(y); - } else if (s == -1) { + } else if (s == -1) { mp_limb_t y = ECL_BIGNUM_LIMBS(x)[0]; if (y <= -MOST_NEGATIVE_FIXNUM) return ecl_make_fixnum(-y); - } - return _ecl_big_register_copy(x); + } + return _ecl_big_register_copy(x); } #if GMP_LIMB_BITS >= FIXNUM_BITS @@ -112,7 +112,7 @@ static const int limbs_per_fixnum = (FIXNUM_BITS + GMP_LIMB_BITS - 1) / GMP_LIMB #endif #define ECL_BIGNUM_ABS_SIZE(x) \ - (ECL_BIGNUM_SIZE(x)<0? -ECL_BIGNUM_SIZE(x) : ECL_BIGNUM_SIZE(x)) + (ECL_BIGNUM_SIZE(x)<0? -ECL_BIGNUM_SIZE(x) : ECL_BIGNUM_SIZE(x)) cl_object _ecl_fix_times_fix(cl_fixnum x, cl_fixnum y) @@ -140,10 +140,10 @@ _ecl_big_times_big(cl_object a, cl_object b) { cl_index size_a = ECL_BIGNUM_ABS_SIZE(a); cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); - cl_index size = size_a + size_b; + cl_index size = size_a + size_b; cl_object z = _ecl_alloc_compact_bignum(size); _ecl_big_mul(z, a, b); - return z; + return z; } @@ -151,23 +151,23 @@ cl_object _ecl_big_times_fix(cl_object b, cl_fixnum i) { cl_index size; - cl_object z; + cl_object z; if (i == 0) return ecl_make_fixnum(0); - if (i == 1) - return b; + if (i == 1) + return b; size = ECL_BIGNUM_ABS_SIZE(b); size += limbs_per_fixnum; z = _ecl_alloc_compact_bignum(size); #if ECL_LONG_BITS >= FIXNUM_BITS _ecl_big_mul_si(z, b, i); #else - { - ECL_WITH_TEMP_BIGNUM(w,4); - _ecl_big_set_fixnum(w, i); - _ecl_big_mul(z, b, w); - } + { + ECL_WITH_TEMP_BIGNUM(w,4); + _ecl_big_set_fixnum(w, i); + _ecl_big_mul(z, b, w); + } #endif return z; } @@ -175,9 +175,9 @@ _ecl_big_times_fix(cl_object b, cl_fixnum i) cl_object _ecl_big_plus_fix(cl_object a, cl_fixnum b) { - ECL_WITH_TEMP_BIGNUM(big_b, 2); - _ecl_big_set_fixnum(big_b, b); - return _ecl_big_plus_big(a, big_b); + ECL_WITH_TEMP_BIGNUM(big_b, 2); + _ecl_big_set_fixnum(big_b, b); + return _ecl_big_plus_big(a, big_b); } cl_object @@ -205,7 +205,7 @@ _ecl_big_minus_big(cl_object a, cl_object b) cl_object _ecl_fix_minus_big(cl_fixnum a, cl_object b) { - cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); + cl_index size_b = ECL_BIGNUM_ABS_SIZE(b); cl_index size_z = size_b + limbs_per_fixnum; cl_object z = _ecl_alloc_compact_bignum(size_z); _ecl_big_set_fixnum(z, a); @@ -288,10 +288,10 @@ mp_alloc(size_t size) static void * mp_realloc(void *ptr, size_t osize, size_t nsize) { - mp_limb_t *p = ecl_alloc_atomic_align(nsize, sizeof(mp_limb_t)); - memcpy(p, ptr, (osize < nsize)? osize : nsize); + mp_limb_t *p = ecl_alloc_atomic_align(nsize, sizeof(mp_limb_t)); + memcpy(p, ptr, (osize < nsize)? osize : nsize); ecl_dealloc(ptr); - return p; + return p; } static void @@ -310,7 +310,7 @@ fixint(cl_object x) return mpz_get_si(x->big.big_num); } } - FEwrong_type_argument(@[fixnum], x); + FEwrong_type_argument(@[fixnum], x); } cl_index @@ -325,9 +325,9 @@ fixnnint(cl_object x) return mpz_get_ui(x->big.big_num); } } - FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), - x); + FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), + x); } #undef _ecl_big_set_fixnum @@ -350,13 +350,13 @@ _ecl_big_set_index(cl_object x, cl_index f) cl_fixnum _ecl_big_get_fixnum(cl_object x) { - return mpz_get_si((x)->big.big_num); + return mpz_get_si((x)->big.big_num); } cl_index _ecl_big_get_index(cl_object x) { - return mpz_get_ui((x)->big.big_num); + return mpz_get_ui((x)->big.big_num); } #elif GMP_LIMB_BITS >= FIXNUM_BITS cl_object @@ -387,24 +387,24 @@ _ecl_big_set_index(cl_object x, cl_index f) cl_fixnum _ecl_big_get_fixnum(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - cl_fixnum output = ECL_BIGNUM_LIMBS(x)[0]; - return (ECL_BIGNUM_SIZE(x) > 0) ? output : -output; + /* INV: x is a bignum and thus size != 0 */ + cl_fixnum output = ECL_BIGNUM_LIMBS(x)[0]; + return (ECL_BIGNUM_SIZE(x) > 0) ? output : -output; } cl_index _ecl_big_get_index(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - cl_index output = ECL_BIGNUM_LIMBS(x)[0]; - return (ECL_BIGNUM_SIZE(x) > 0)? output : ~(output - 1); + /* INV: x is a bignum and thus size != 0 */ + cl_index output = ECL_BIGNUM_LIMBS(x)[0]; + return (ECL_BIGNUM_SIZE(x) > 0)? output : ~(output - 1); } bool _ecl_big_fits_in_index(cl_object x) { - /* INV: x is a bignum and thus size != 0 */ - return (ECL_BIGNUM_SIZE(x) ^ 1) == 0; + /* INV: x is a bignum and thus size != 0 */ + return (ECL_BIGNUM_SIZE(x) ^ 1) == 0; } #else # error "ECL cannot build with GMP when both long and mp_limb_t are smaller than cl_fixnum" @@ -427,82 +427,82 @@ _ecl_big_to_long_double(cl_object o) static void mpz_ior_op(cl_object out, cl_object i, cl_object j) { - mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_xor_op(cl_object out, cl_object i, cl_object j) { - mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_and_op(cl_object out, cl_object i, cl_object j) { - mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); } static void mpz_eqv_op(cl_object out, cl_object i, cl_object j) { - mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_xor(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_nand_op(cl_object out, cl_object i, cl_object j) { - mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_and(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_nor_op(cl_object out, cl_object i, cl_object j) { - mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); - mpz_com(out->big.big_num, out->big.big_num); + mpz_ior(out->big.big_num, i->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_andc1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); - mpz_and(out->big.big_num, out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); + mpz_and(out->big.big_num, out->big.big_num, j->big.big_num); } static void mpz_orc1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); - mpz_ior(out->big.big_num, out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); + mpz_ior(out->big.big_num, out->big.big_num, j->big.big_num); } static void mpz_andc2_op(cl_object out, cl_object i, cl_object j) { - /* (i & ~j) = ~((~i) | j) */ - mpz_orc1_op(out, i, j); - mpz_com(out->big.big_num, out->big.big_num); + /* (i & ~j) = ~((~i) | j) */ + mpz_orc1_op(out, i, j); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_orc2_op(cl_object out, cl_object i, cl_object j) { - /* (i | ~j) = ~((~i) & j) */ - mpz_andc1_op(out, i, j); - mpz_com(out->big.big_num, out->big.big_num); + /* (i | ~j) = ~((~i) & j) */ + mpz_andc1_op(out, i, j); + mpz_com(out->big.big_num, out->big.big_num); } static void mpz_b_clr_op(cl_object out, cl_object i, cl_object j) { - mpz_set_si(out->big.big_num, 0); + mpz_set_si(out->big.big_num, 0); } static void mpz_b_set_op(cl_object o, cl_object i, cl_object j) { - mpz_set_si(o->big.big_num, -1); + mpz_set_si(o->big.big_num, -1); } static void @@ -515,38 +515,38 @@ mpz_b_1_op(cl_object out, cl_object i, cl_object j) static void mpz_b_2_op(cl_object out, cl_object i, cl_object j) { - mpz_set(out->big.big_num, j->big.big_num); + mpz_set(out->big.big_num, j->big.big_num); } static void mpz_b_c1_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, i->big.big_num); + mpz_com(out->big.big_num, i->big.big_num); } static void mpz_b_c2_op(cl_object out, cl_object i, cl_object j) { - mpz_com(out->big.big_num, j->big.big_num); + mpz_com(out->big.big_num, j->big.big_num); } static _ecl_big_binary_op bignum_operations[16] = { - mpz_b_clr_op, - mpz_and_op, - mpz_andc2_op, - mpz_b_1_op, - mpz_andc1_op, - mpz_b_2_op, - mpz_xor_op, - mpz_ior_op, - mpz_nor_op, - mpz_eqv_op, - mpz_b_c2_op, - mpz_orc2_op, - mpz_b_c1_op, - mpz_orc1_op, - mpz_nand_op, - mpz_b_set_op}; + mpz_b_clr_op, + mpz_and_op, + mpz_andc2_op, + mpz_b_1_op, + mpz_andc1_op, + mpz_b_2_op, + mpz_xor_op, + mpz_ior_op, + mpz_nor_op, + mpz_eqv_op, + mpz_b_c2_op, + mpz_orc2_op, + mpz_b_c1_op, + mpz_orc1_op, + mpz_nand_op, + mpz_b_set_op}; _ecl_big_binary_op _ecl_big_boole_operator(int op) diff --git a/src/c/big_ll.d b/src/c/big_ll.d index 9d244219b..0aa3aabe0 100644 --- a/src/c/big_ll.d +++ b/src/c/big_ll.d @@ -22,15 +22,15 @@ _ecl_big_register_free(cl_object x) {} cl_object _ecl_big_register_copy(cl_object old) { - cl_object new_big = ecl_alloc_object(t_bignum); + cl_object new_big = ecl_alloc_object(t_bignum); new_big->big.big_num = old->big.big_num; - return new_big; + return new_big; } static cl_object big_normalize(cl_object x) { - if (x->big.big_num == 0ll) + if (x->big.big_num == 0ll) return(ecl_make_fixnum(0)); if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) return(ecl_make_fixnum(x->big.big_num)); @@ -40,29 +40,29 @@ big_normalize(cl_object x) cl_object _ecl_big_register_normalize(cl_object x) { - if (x->big.big_num == 0ll) + if (x->big.big_num == 0ll) return(ecl_make_fixnum(0)); if (x->big.big_num <= MOST_POSITIVE_FIXNUM && x->big.big_num >= MOST_NEGATIVE_FIXNUM) return(ecl_make_fixnum(x->big.big_num)); - return _ecl_big_register_copy(x); + return _ecl_big_register_copy(x); } static cl_object big_alloc(int size) { - volatile cl_object x = ecl_alloc_object(t_bignum); - if (size <= 0) - ecl_internal_error("negative or zero size for bignum in big_alloc"); - x->big.big_num = 0ll; - return x; + volatile cl_object x = ecl_alloc_object(t_bignum); + if (size <= 0) + ecl_internal_error("negative or zero size for bignum in big_alloc"); + x->big.big_num = 0ll; + return x; } static cl_object _ecl_big_copy(cl_object x) { - volatile cl_object y = ecl_alloc_object(t_bignum); + volatile cl_object y = ecl_alloc_object(t_bignum); y->big.big_num = x->big.big_num; - return y; + return y; } cl_object @@ -90,7 +90,7 @@ _ecl_big_gcd(cl_object x, cl_object y) int _ecl_big_num_t_sgn(big_num_t x) { - return ( x == (big_num_t)0 ) ? 0 : (x < (big_num_t)0) ? -1 : 1; + return ( x == (big_num_t)0 ) ? 0 : (x < (big_num_t)0) ? -1 : 1; } cl_object @@ -98,15 +98,15 @@ _ecl_big_times_big(cl_object x, cl_object y) { cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = x->big.big_num * y->big.big_num; - return z; + return z; } cl_object _ecl_big_times_fix(cl_object x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = x->big.big_num * y; - return big_normalize(z); + return big_normalize(z); } cl_object @@ -114,23 +114,23 @@ _ecl_big_plus_big(cl_object x, cl_object y) { cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = x->big.big_num + y->big.big_num; - return z; + return z; } cl_object _ecl_big_plus_fix(cl_object x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = x->big.big_num + y; - return big_normalize(z); + return big_normalize(z); } cl_object _ecl_fix_times_fix(cl_fixnum x, cl_fixnum y) { - cl_object z = ecl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = x * y; - return big_normalize(z); + return big_normalize(z); } cl_object @@ -158,9 +158,9 @@ _ecl_big_floor(cl_object a, cl_object b, cl_object *pr) cl_object _ecl_big_negate(cl_object x) { - cl_object z = ecl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = -x->big.big_num; - return z; + return z; } void diff --git a/src/c/cfun.d b/src/c/cfun.d index 64b3892ac..0f1c9a281 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -16,152 +16,152 @@ */ #include -#include /* for memmove() */ +#include /* for memmove() */ #include "cfun_dispatch.d" cl_object ecl_make_cfun(cl_objectfn_fixed c_function, cl_object name, cl_object cblock, int narg) { - cl_object cf; + cl_object cf; - cf = ecl_alloc_object(t_cfunfixed); - cf->cfunfixed.entry = dispatch_table[narg]; - cf->cfunfixed.entry_fixed = c_function; - cf->cfunfixed.name = name; - cf->cfunfixed.block = cblock; + cf = ecl_alloc_object(t_cfunfixed); + cf->cfunfixed.entry = dispatch_table[narg]; + cf->cfunfixed.entry_fixed = c_function; + cf->cfunfixed.name = name; + cf->cfunfixed.block = cblock; cf->cfunfixed.file = ECL_NIL; cf->cfunfixed.file_position = ecl_make_fixnum(-1); - cf->cfunfixed.narg = narg; - if (ecl_unlikely(narg < 0 || narg > ECL_C_ARGUMENTS_LIMIT)) + cf->cfunfixed.narg = narg; + if (ecl_unlikely(narg < 0 || narg > ECL_C_ARGUMENTS_LIMIT)) FEprogram_error_noreturn("ecl_make_cfun: function requires " "too many arguments.",0); - return cf; + return cf; } cl_object ecl_make_cfun_va(cl_objectfn c_function, cl_object name, cl_object cblock) { - cl_object cf; + cl_object cf; - cf = ecl_alloc_object(t_cfun); - cf->cfun.entry = c_function; - cf->cfun.name = name; - cf->cfun.block = cblock; - cf->cfun.narg = -1; + cf = ecl_alloc_object(t_cfun); + cf->cfun.entry = c_function; + cf->cfun.name = name; + cf->cfun.block = cblock; + cf->cfun.narg = -1; cf->cfun.file = ECL_NIL; cf->cfun.file_position = ecl_make_fixnum(-1); - return cf; + return cf; } cl_object ecl_make_cclosure_va(cl_objectfn c_function, cl_object env, cl_object block) { - cl_object cc; + cl_object cc; - cc = ecl_alloc_object(t_cclosure); - cc->cclosure.entry = c_function; - cc->cclosure.env = env; - cc->cclosure.block = block; + cc = ecl_alloc_object(t_cclosure); + cc->cclosure.entry = c_function; + cc->cclosure.env = env; + cc->cclosure.block = block; cc->cclosure.file = ECL_NIL; cc->cclosure.file_position = ecl_make_fixnum(-1); - return cc; + return cc; } void ecl_def_c_function(cl_object sym, cl_objectfn_fixed c_function, int narg) { - si_fset(2, sym, - ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), narg)); + si_fset(2, sym, + ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), narg)); } void ecl_def_c_macro(cl_object sym, cl_objectfn_fixed c_function, int narg) { - si_fset(3, sym, - ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), 2), - ECL_T); + si_fset(3, sym, + ecl_make_cfun(c_function, sym, ecl_symbol_value(@'si::*cblock*'), 2), + ECL_T); } void ecl_def_c_macro_va(cl_object sym, cl_objectfn c_function) { - si_fset(3, sym, - ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*')), - ECL_T); + si_fset(3, sym, + ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*')), + ECL_T); } void ecl_def_c_function_va(cl_object sym, cl_objectfn c_function) { - si_fset(2, sym, - ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*'))); + si_fset(2, sym, + ecl_make_cfun_va(c_function, sym, ecl_symbol_value(@'si::*cblock*'))); } cl_object si_compiled_function_name(cl_object fun) { - cl_env_ptr the_env = ecl_process_env(); - cl_object output; + cl_env_ptr the_env = ecl_process_env(); + cl_object output; - switch(ecl_t_of(fun)) { - case t_bclosure: - fun = fun->bclosure.code; - case t_bytecodes: - output = fun->bytecodes.name; break; - case t_cfun: - case t_cfunfixed: - output = fun->cfun.name; break; - case t_cclosure: - output = ECL_NIL; break; - default: - FEinvalid_function(fun); - } - ecl_return1(the_env, output); + switch(ecl_t_of(fun)) { + case t_bclosure: + fun = fun->bclosure.code; + case t_bytecodes: + output = fun->bytecodes.name; break; + case t_cfun: + case t_cfunfixed: + output = fun->cfun.name; break; + case t_cclosure: + output = ECL_NIL; break; + default: + FEinvalid_function(fun); + } + ecl_return1(the_env, output); } cl_object cl_function_lambda_expression(cl_object fun) { - cl_env_ptr the_env = ecl_process_env(); - cl_object output, name = ECL_NIL, lex = ECL_NIL; + cl_env_ptr the_env = ecl_process_env(); + cl_object output, name = ECL_NIL, lex = ECL_NIL; - switch(ecl_t_of(fun)) { - case t_bclosure: - lex = fun->bclosure.lex; - fun = fun->bclosure.code; - case t_bytecodes: - name = fun->bytecodes.name; - output = fun->bytecodes.definition; - if (name == ECL_NIL) - output = cl_cons(@'lambda', output); - else if (name != @'si::bytecodes') - output = @list*(3, @'ext::lambda-block', name, output); - break; - case t_cfun: - case t_cfunfixed: - name = fun->cfun.name; - lex = ECL_NIL; - output = ECL_NIL; - break; - case t_cclosure: - name = ECL_NIL; - lex = ECL_T; - output = ECL_NIL; - break; + switch(ecl_t_of(fun)) { + case t_bclosure: + lex = fun->bclosure.lex; + fun = fun->bclosure.code; + case t_bytecodes: + name = fun->bytecodes.name; + output = fun->bytecodes.definition; + if (name == ECL_NIL) + output = cl_cons(@'lambda', output); + else if (name != @'si::bytecodes') + output = @list*(3, @'ext::lambda-block', name, output); + break; + case t_cfun: + case t_cfunfixed: + name = fun->cfun.name; + lex = ECL_NIL; + output = ECL_NIL; + break; + case t_cclosure: + name = ECL_NIL; + lex = ECL_T; + output = ECL_NIL; + break; #ifdef CLOS - case t_instance: - if (fun->instance.isgf) { - name = ECL_NIL; - lex = ECL_NIL; - output = ECL_NIL; - break; - } + case t_instance: + if (fun->instance.isgf) { + name = ECL_NIL; + lex = ECL_NIL; + output = ECL_NIL; + break; + } #endif - default: - FEinvalid_function(fun); - } - ecl_return3(the_env, output, lex, name); + default: + FEinvalid_function(fun); + } + ecl_return3(the_env, output, lex, name); } cl_object @@ -171,13 +171,13 @@ si_compiled_function_block(cl_object fun) switch(ecl_t_of(fun)) { case t_cfun: - output = fun->cfun.block; break; + output = fun->cfun.block; break; case t_cfunfixed: - output = fun->cfunfixed.block; break; + output = fun->cfunfixed.block; break; case t_cclosure: - output = fun->cclosure.block; break; + output = fun->cclosure.block; break; default: - FEerror("~S is not a C compiled function.", 1, fun); + FEerror("~S is not a C compiled function.", 1, fun); } @(return output) } @@ -185,23 +185,23 @@ si_compiled_function_block(cl_object fun) cl_object si_compiled_function_file(cl_object b) { - cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr the_env = ecl_process_env(); BEGIN: switch (ecl_t_of(b)) { case t_bclosure: b = b->bclosure.code; goto BEGIN; case t_bytecodes: - ecl_return2(the_env, b->bytecodes.file, b->bytecodes.file_position); + ecl_return2(the_env, b->bytecodes.file, b->bytecodes.file_position); case t_cfun: - ecl_return2(the_env, b->cfun.file, b->cfun.file_position); + ecl_return2(the_env, b->cfun.file, b->cfun.file_position); case t_cfunfixed: - ecl_return2(the_env, b->cfunfixed.file, b->cfunfixed.file_position); + ecl_return2(the_env, b->cfunfixed.file, b->cfunfixed.file_position); case t_cclosure: - ecl_return2(the_env, b->cclosure.file, b->cclosure.file_position); + ecl_return2(the_env, b->cclosure.file, b->cclosure.file_position); default: - ecl_return2(the_env, ECL_NIL, ECL_NIL); - } + ecl_return2(the_env, ECL_NIL, ECL_NIL); + } } void @@ -230,17 +230,17 @@ ecl_set_function_source_file_info(cl_object b, cl_object source, cl_object posit break; default: FEerror("~S is not a compiled function.", 1, b); - } + } } void ecl_cmp_defmacro(cl_object fun) { - si_fset(3, fun->cfun.name, fun, ECL_T); + si_fset(3, fun->cfun.name, fun, ECL_T); } void ecl_cmp_defun(cl_object fun) { - si_fset(2, fun->cfun.name, fun); + si_fset(2, fun->cfun.name, fun); } diff --git a/src/c/char_ctype.d b/src/c/char_ctype.d index 81781f863..a2f0d92c0 100644 --- a/src/c/char_ctype.d +++ b/src/c/char_ctype.d @@ -21,49 +21,49 @@ bool ecl_graphic_char_p(ecl_character code) { - return code == ' ' || isgraph(code); + return code == ' ' || isgraph(code); } bool ecl_alpha_char_p(ecl_character code) { - return isalpha(code); + return isalpha(code); } bool ecl_upper_case_p(ecl_character code) { - return isupper(code); + return isupper(code); } bool ecl_lower_case_p(ecl_character code) { - return islower(code); + return islower(code); } bool ecl_both_case_p(ecl_character code) { - return islower(code) || isupper(code); + return islower(code) || isupper(code); } bool ecl_alphanumericp(ecl_character i) { - return isalnum(i); + return isalnum(i); } ecl_character ecl_char_upcase(ecl_character code) { - return toupper(code); + return toupper(code); } ecl_character ecl_char_downcase(ecl_character code) { - return tolower(code); + return tolower(code); } #else /* ECL_UNICODE */ @@ -80,16 +80,16 @@ extern const unsigned char ecl_ucd_page_table_1[]; const unsigned char * ucd_char_data(ecl_character code) { - const unsigned char *page = ecl_ucd_page_table[code >> 8]; + const unsigned char *page = ecl_ucd_page_table[code >> 8]; return page + (4 * (code & 0xFF)); } static cl_index ucd_value_0(ecl_character code) { - if (ecl_unlikely((code >= 0x110000))) - FEerror("The value ~A is not of type (MOD 1114112)", 1, code); - return ucd_char_data(code)[0]; + if (ecl_unlikely((code >= 0x110000))) + FEerror("The value ~A is not of type (MOD 1114112)", 1, code); + return ucd_char_data(code)[0]; } #define read_case_bytes(c) (c[1] + (c[2] << 8) + (c[3] << 16)) @@ -104,14 +104,14 @@ ucd_value_0(ecl_character code) const unsigned char * ucd_char_data(ecl_character code) { - const unsigned char *page = ecl_ucd_page_table[code >> 8]; + const unsigned char *page = ecl_ucd_page_table[code >> 8]; return page + (3 * (code & 0xFF)); } static cl_index ucd_value_0(ecl_character code) { - return ucd_char_data(code)[0]; + return ucd_char_data(code)[0]; } #define read_case_bytes(c) (c[1] + (c[2] << 8)) @@ -120,72 +120,72 @@ ucd_value_0(ecl_character code) static int ucd_general_category(ecl_character code) { - return ecl_ucd_misc_table[8 * ucd_value_0(code)]; + return ecl_ucd_misc_table[8 * ucd_value_0(code)]; } static int ucd_decimal_digit(ecl_character code) { - return ecl_ucd_misc_table[3 + 8 * ucd_value_0(code)]; + return ecl_ucd_misc_table[3 + 8 * ucd_value_0(code)]; } bool ecl_graphic_char_p(ecl_character code) { - /* compatible to SBCL */ - return code > 159 || ((31 < code) && (code < 127)); + /* compatible to SBCL */ + return code > 159 || ((31 < code) && (code < 127)); } bool ecl_alpha_char_p(ecl_character code) { - return ucd_general_category(code) < 5; + return ucd_general_category(code) < 5; } bool ecl_upper_case_p(ecl_character code) { - return ucd_value_0(code) == 0; + return ucd_value_0(code) == 0; } bool ecl_lower_case_p(ecl_character code) { - return ucd_value_0(code) == 1; + return ucd_value_0(code) == 1; } bool ecl_both_case_p(ecl_character code) { - return ucd_value_0(code) < 2; + return ucd_value_0(code) < 2; } bool ecl_alphanumericp(ecl_character i) { - int gc = ucd_general_category(i); - return (gc < 5) || (gc == 12); + int gc = ucd_general_category(i); + return (gc < 5) || (gc == 12); } ecl_character ecl_char_upcase(ecl_character code) { - const unsigned char *c = ucd_char_data(code); - if (c[0] == 1) { - return read_case_bytes(c); - } else { - return code; - } + const unsigned char *c = ucd_char_data(code); + if (c[0] == 1) { + return read_case_bytes(c); + } else { + return code; + } } ecl_character ecl_char_downcase(ecl_character code) { - const unsigned char *c = ucd_char_data(code); - if (c[0] == 0) { - return read_case_bytes(c); - } else { - return code; - } + const unsigned char *c = ucd_char_data(code); + if (c[0] == 0) { + return read_case_bytes(c); + } else { + return code; + } } #endif diff --git a/src/c/character.d b/src/c/character.d index a7f126702..5c00b4aef 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -23,7 +23,7 @@ ecl_character ecl_char_code(cl_object c) { - if (ecl_unlikely(!ECL_CHARACTERP(c))) + if (ecl_unlikely(!ECL_CHARACTERP(c))) FEwrong_type_only_arg(@[char-code], c, @[character]); return ECL_CHAR_CODE(c); } @@ -32,108 +32,108 @@ ecl_base_char ecl_base_char_code(cl_object c) { #ifdef ECL_UNICODE - if (ECL_CHARACTERP(c)) { - cl_fixnum code = ECL_CHAR_CODE(c); - if (code <= 255) { - return (int)code; - } - } - FEwrong_type_only_arg(@[char-code], c, @[base-char]); + if (ECL_CHARACTERP(c)) { + cl_fixnum code = ECL_CHAR_CODE(c); + if (code <= 255) { + return (int)code; + } + } + FEwrong_type_only_arg(@[char-code], c, @[base-char]); #else - return ecl_char_code(c); + return ecl_char_code(c); #endif } cl_object cl_standard_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - cl_fixnum i = ecl_char_code(c); - @(return (ecl_standard_char_p(i)? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + cl_fixnum i = ecl_char_code(c); + @(return (ecl_standard_char_p(i)? ECL_T : ECL_NIL)) } bool ecl_standard_char_p(ecl_character code) { - return ((' ' <= code) && (code < '\177')) || (code == '\n'); + return ((' ' <= code) && (code < '\177')) || (code == '\n'); } bool ecl_base_char_p(ecl_character c) { - return c <= 255; + return c <= 255; } cl_object cl_graphic_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_graphic_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_graphic_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) } cl_object cl_alpha_char_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_alpha_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_alpha_char_p(ecl_char_code(c))? ECL_T : ECL_NIL)) } cl_object cl_upper_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_upper_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_upper_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) } cl_object cl_lower_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_lower_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_lower_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) } cl_object cl_both_case_p(cl_object c) { - /* INV: ecl_char_code() checks the type */ - @(return (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks the type */ + @(return (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)) } int ecl_string_case(cl_object s) { - int upcase; - cl_index i; - ecl_base_char *text; - - switch (ecl_t_of(s)) { + int upcase; + cl_index i; + ecl_base_char *text; + + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: - s = si_coerce_to_base_string(s); + case t_string: + s = si_coerce_to_base_string(s); #endif - case t_base_string: - text = (ecl_base_char*)s->base_string.self; - for (i = 0, upcase = 0; i < s->base_string.dim; i++) { - if (ecl_upper_case_p(text[i])) { - if (upcase < 0) - return 0; - upcase = +1; - } else if (ecl_lower_case_p(text[i])) { - if (upcase > 0) - return 0; - upcase = -1; - } - } - break; - default: - FEwrong_type_argument(@[string], s); - } - return upcase; + case t_base_string: + text = (ecl_base_char*)s->base_string.self; + for (i = 0, upcase = 0; i < s->base_string.dim; i++) { + if (ecl_upper_case_p(text[i])) { + if (upcase < 0) + return 0; + upcase = +1; + } else if (ecl_lower_case_p(text[i])) { + if (upcase > 0) + return 0; + upcase = -1; + } + } + break; + default: + FEwrong_type_argument(@[string], s); + } + return upcase; } @(defun digit_char_p (c &optional (radix ecl_make_fixnum(10))) @ { - cl_fixnum basis, value; + cl_fixnum basis, value; if (ecl_unlikely(!ECL_FIXNUMP(radix) || ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { @@ -142,130 +142,130 @@ ecl_string_case(cl_object s) ecl_make_fixnum(36))); } basis = ecl_fixnum(radix); - value = ecl_digitp(ecl_char_code(c), basis); - @(return ((value < 0)? ECL_NIL: ecl_make_fixnum(value))); + value = ecl_digitp(ecl_char_code(c), basis); + @(return ((value < 0)? ECL_NIL: ecl_make_fixnum(value))); } @) /* - Ecl_Digitp(i, r) returns the weight of code i - as a digit of radix r, which must be 1 < r <= 36. - If i is not a digit, -1 is returned. + Ecl_Digitp(i, r) returns the weight of code i + as a digit of radix r, which must be 1 < r <= 36. + If i is not a digit, -1 is returned. */ int ecl_digitp(ecl_character i, int r) { - if (('0' <= i) && (i <= '9') && (i < '0' + r)) - return i - '0'; - if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10))) - return i - 'A' + 10; - if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10))) - return i - 'a' + 10; + if (('0' <= i) && (i <= '9') && (i < '0' + r)) + return i - '0'; + if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10))) + return i - 'A' + 10; + if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10))) + return i - 'a' + 10; #ifdef ECL_UNICODE - if (i > 255) { - int number = ucd_decimal_digit(i); - if (number < r) - return number; - } + if (i > 255) { + int number = ucd_decimal_digit(i); + if (number < r) + return number; + } #endif - return -1; + return -1; } cl_object cl_alphanumericp(cl_object c) { - /* INV: ecl_char_code() checks type of `c' */ - cl_fixnum i = ecl_char_code(c); - @(return (ecl_alphanumericp(i)? ECL_T : ECL_NIL)) + /* INV: ecl_char_code() checks type of `c' */ + cl_fixnum i = ecl_char_code(c); + @(return (ecl_alphanumericp(i)? ECL_T : ECL_NIL)) } @(defun char= (c &rest cs) @ - /* INV: ecl_char_eq() checks types of `c' and `cs' */ - while (--narg) - if (!ecl_char_eq(c, ecl_va_arg(cs))) - @(return ECL_NIL) - @(return ECL_T) + /* INV: ecl_char_eq() checks types of `c' and `cs' */ + while (--narg) + if (!ecl_char_eq(c, ecl_va_arg(cs))) + @(return ECL_NIL) + @(return ECL_T) @) bool ecl_char_eq(cl_object x, cl_object y) { - return ecl_char_code(x) == ecl_char_code(y); + return ecl_char_code(x) == ecl_char_code(y); } @(defun char/= (&rest cs) - int i, j; - cl_object c; + int i, j; + cl_object c; @ - /* INV: ecl_char_eq() checks types of its arguments */ - if (narg == 0) - FEwrong_num_arguments(@[char/=]); - c = ecl_va_arg(cs); - for (i = 2; i<=narg; i++) { - ecl_va_list ds; - ecl_va_start(ds, narg, narg, 0); - c = ecl_va_arg(cs); - for (j = 1; j (&rest args) @ - return Lchar_cmp(the_env, narg,-1, 1, args); + return Lchar_cmp(the_env, narg,-1, 1, args); @) @(defun char<= (&rest args) @ - return Lchar_cmp(the_env, narg, 1, 0, args); + return Lchar_cmp(the_env, narg, 1, 0, args); @) @(defun char>= (&rest args) @ - return Lchar_cmp(the_env, narg,-1, 0, args); + return Lchar_cmp(the_env, narg,-1, 0, args); @) @(defun char_equal (c &rest cs) - int i; + int i; @ - /* INV: ecl_char_equal() checks the type of its arguments */ - for (narg--, i = 0; i < narg; i++) { - if (!ecl_char_equal(c, ecl_va_arg(cs))) - @(return ECL_NIL) - } - @(return ECL_T) + /* INV: ecl_char_equal() checks the type of its arguments */ + for (narg--, i = 0; i < narg; i++) { + if (!ecl_char_equal(c, ecl_va_arg(cs))) + @(return ECL_NIL) + } + @(return ECL_T) @) #define char_equal_code(x) ecl_char_upcase(ecl_char_code(x)) @@ -273,149 +273,149 @@ ecl_char_cmp(cl_object x, cl_object y) bool ecl_char_equal(cl_object x, cl_object y) { - return char_equal_code(x) == char_equal_code(y); + return char_equal_code(x) == char_equal_code(y); } @(defun char-not-equal (&rest cs) - int i, j; - cl_object c; + int i, j; + cl_object c; @ - /* INV: ecl_char_equal() checks the type of its arguments */ - if (narg == 0) - FEwrong_num_arguments(@[char-not-equal]); - c = ecl_va_arg(cs); - for (i = 2; i<=narg; i++) { - ecl_va_list ds; - ecl_va_start(ds, narg, narg, 0); - c = ecl_va_arg(cs); - for (j=1; jsymbol.name); + switch (ecl_t_of(x)) { + case t_character: + break; + case t_symbol: + return cl_character(x->symbol.name); #ifdef ECL_UNICODE - case t_string: - if (x->string.fillp == 1) { - x = ECL_CODE_CHAR(x->string.self[0]); - break; - } - goto ERROR; + case t_string: + if (x->string.fillp == 1) { + x = ECL_CODE_CHAR(x->string.self[0]); + break; + } + goto ERROR; #endif - case t_base_string: - if (x->base_string.fillp == 1) { - x = ECL_CODE_CHAR(x->base_string.self[0]); - break; - } - default: ERROR: + case t_base_string: + if (x->base_string.fillp == 1) { + x = ECL_CODE_CHAR(x->base_string.self[0]); + break; + } + default: ERROR: FEwrong_type_nth_arg(@[character], 1, x, ecl_read_from_cstring("(OR CHARACTER SYMBOL (ARRAY CHARACTER (1)) (ARRAY BASE-CHAR (1)))")); - } - @(return x) + } + @(return x) } cl_object cl_char_code(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - @(return ecl_make_fixnum(ecl_char_code(c))) + /* INV: ecl_char_code() checks the type of `c' */ + @(return ecl_make_fixnum(ecl_char_code(c))) } cl_object cl_code_char(cl_object c) { - cl_fixnum fc; + cl_fixnum fc; - switch (ecl_t_of(c)) { - case t_fixnum: - fc = ecl_fixnum(c); - if (fc < ECL_CHAR_CODE_LIMIT && fc >= 0) { - c = ECL_CODE_CHAR(fc); - break; - } - case t_bignum: - c = ECL_NIL; - break; - default: + switch (ecl_t_of(c)) { + case t_fixnum: + fc = ecl_fixnum(c); + if (fc < ECL_CHAR_CODE_LIMIT && fc >= 0) { + c = ECL_CODE_CHAR(fc); + break; + } + case t_bignum: + c = ECL_NIL; + break; + default: FEwrong_type_only_arg(@[code-char], c, @[integer]); - } - @(return c) + } + @(return c) } cl_object cl_char_upcase(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - cl_fixnum code = ecl_char_code(c); - @(return ECL_CODE_CHAR(ecl_char_upcase(code))) + /* INV: ecl_char_code() checks the type of `c' */ + cl_fixnum code = ecl_char_code(c); + @(return ECL_CODE_CHAR(ecl_char_upcase(code))) } cl_object cl_char_downcase(cl_object c) { - /* INV: ecl_char_code() checks the type of `c' */ - cl_fixnum code = ecl_char_code(c); - @(return ECL_CODE_CHAR(ecl_char_downcase(code))) + /* INV: ecl_char_code() checks the type of `c' */ + cl_fixnum code = ecl_char_code(c); + @(return ECL_CODE_CHAR(ecl_char_downcase(code))) } @(defun digit_char (weight &optional (radix ecl_make_fixnum(10))) @@ -430,42 +430,42 @@ cl_char_downcase(cl_object c) ecl_make_fixnum(36))); } basis = ecl_fixnum(radix); - switch (ecl_t_of(weight)) { - case t_fixnum: { - cl_fixnum value = ecl_fixnum(weight); - if (value >= 0) { - int dw = ecl_digit_char(value, basis); - if (dw >= 0) { - output = ECL_CODE_CHAR(dw); - } - } - break; - } - case t_bignum: - break; - default: + switch (ecl_t_of(weight)) { + case t_fixnum: { + cl_fixnum value = ecl_fixnum(weight); + if (value >= 0) { + int dw = ecl_digit_char(value, basis); + if (dw >= 0) { + output = ECL_CODE_CHAR(dw); + } + } + break; + } + case t_bignum: + break; + default: FEwrong_type_nth_arg(@[digit-char],1,weight,@[integer]); - } - @(return output) + } + @(return output) } @) short ecl_digit_char(cl_fixnum w, cl_fixnum r) { - if (r < 2 || r > 36 || w < 0 || w >= r) - return(-1); - if (w < 10) - return(w + '0'); - else - return(w - 10 + 'A'); + if (r < 2 || r > 36 || w < 0 || w >= r) + return(-1); + if (w < 10) + return(w + '0'); + else + return(w - 10 + 'A'); } cl_object cl_char_int(cl_object c) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: ecl_char_code() checks the type of `c' */ - ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c))); + const cl_env_ptr the_env = ecl_process_env(); + /* INV: ecl_char_code() checks the type of `c' */ + ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c))); } /* here we give every character an implicit name of the form 'u#' where # is a hexadecimal number, @@ -476,18 +476,18 @@ cl_char_int(cl_object c) cl_object cl_char_name(cl_object c) { - ecl_character code = ecl_char_code(c); - cl_object output; - if (code <= 127) { - output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); - } + ecl_character code = ecl_char_code(c); + cl_object output; + if (code <= 127) { + output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); + } #ifdef ECL_UNICODE_NAMES - else if (!Null(output = _ecl_ucd_code_to_name(code))) { - (void)0; - } + else if (!Null(output = _ecl_ucd_code_to_name(code))) { + (void)0; + } #endif - else { - ecl_base_char name[8]; + else { + ecl_base_char name[8]; ecl_base_char *start; name[7] = 0; name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4; @@ -502,46 +502,46 @@ cl_char_name(cl_object c) start = name; } start[0] = 'U'; - output = make_base_string_copy((const char*)start); - } - @(return output); + output = make_base_string_copy((const char*)start); + } + @(return output); } cl_object cl_name_char(cl_object name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object c; - cl_index l; - name = cl_string(name); - c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + cl_object c; + cl_index l; + name = cl_string(name); + c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); if (c != ECL_NIL) { ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c))); } #ifdef ECL_UNICODE_NAMES - c = _ecl_ucd_name_to_code(name); - if (c != ECL_NIL) { - ecl_return1(the_env, cl_code_char(c)); - } + c = _ecl_ucd_name_to_code(name); + if (c != ECL_NIL) { + ecl_return1(the_env, cl_code_char(c)); + } #endif - if (ecl_stringp(name) && (l = ecl_length(name))) { - c = cl_char(name, ecl_make_fixnum(0)); - if (l == 1) { - (void)0; - } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { - c = ECL_NIL; - } else { - cl_index used_l; - cl_index end = name->base_string.fillp; - cl_index real_end = end; - c = ecl_parse_integer(name, 1, end, &real_end, 16); - used_l = real_end; - if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { - c = ECL_NIL; - } else { - c = ECL_CODE_CHAR(ecl_fixnum(c)); - } - } - } - ecl_return1(the_env, c); + if (ecl_stringp(name) && (l = ecl_length(name))) { + c = cl_char(name, ecl_make_fixnum(0)); + if (l == 1) { + (void)0; + } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { + c = ECL_NIL; + } else { + cl_index used_l; + cl_index end = name->base_string.fillp; + cl_index real_end = end; + c = ecl_parse_integer(name, 1, end, &real_end, 16); + used_l = real_end; + if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { + c = ECL_NIL; + } else { + c = ECL_CODE_CHAR(ecl_fixnum(c)); + } + } + } + ecl_return1(the_env, c); } diff --git a/src/c/cinit.d b/src/c/cinit.d index 29aaf546f..b98361465 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -31,7 +31,7 @@ extern cl_object cl_upgraded_array_element_type(cl_narg narg, cl_object type, ...) { - return _ecl_funcall2(@'upgraded-array-element-type', type); + return _ecl_funcall2(@'upgraded-array-element-type', type); } extern cl_object @@ -49,49 +49,49 @@ si_safe_eval(cl_narg narg, cl_object form, cl_object env, ...) extern cl_object cl_slot_value(cl_object instance, cl_object name) { - return _ecl_funcall3(@'slot-value', instance, name); + return _ecl_funcall3(@'slot-value', instance, name); } extern cl_object clos_slot_value_set(cl_object value, cl_object instance, cl_object name) { - return _ecl_funcall4(@'clos::slot-value-set', value, instance, name); + return _ecl_funcall4(@'clos::slot-value-set', value, instance, name); } extern cl_object clos_std_compute_applicable_methods(cl_object gf, cl_object arglist) { - return _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); + return _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); } extern cl_object si_bind_simple_restarts(cl_object tag, cl_object names) { - if (ECL_SYM_FUN(@'si::bind-simple-restarts') != Cnil) - return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); - else - return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); + if (ECL_SYM_FUN(@'si::bind-simple-restarts') != Cnil) + return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); + else + return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); } extern cl_object si_bind_simple_handlers(cl_object tag, cl_object names) { - if (ECL_SYM_FUN(@'si::bind-simple-handlers') != Cnil) - return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); - else - return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); + if (ECL_SYM_FUN(@'si::bind-simple-handlers') != Cnil) + return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); + else + return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); } extern cl_object clos_std_compute_effective_method(cl_object gf, cl_object combination, cl_object methods_list) { - return _ecl_funcall4(@'clos::std-compute-effective-method', gf, combination, methods_list); + return _ecl_funcall4(@'clos::std-compute-effective-method', gf, combination, methods_list); } extern cl_object clos_compute_effective_method_function(cl_object gf, cl_object combination, cl_object methods_list) { - return _ecl_funcall4(@'clos::compute-effective-method-function', gf, combination, methods_list); + return _ecl_funcall4(@'clos::compute-effective-method-function', gf, combination, methods_list); } extern cl_object @@ -109,12 +109,12 @@ si_string_to_object(cl_narg narg, cl_object string, ...) extern cl_object si_signal_simple_error(cl_narg narg, cl_object condition, cl_object continuable, cl_object format, cl_object format_args, ...) { - ecl_va_list args; - cl_object rest; - ecl_va_start(args, format_args, narg, 4); - rest = cl_grab_rest_args(args); - return cl_apply(6, @'si::signal-simple-error', condition, continuable, - format, format_args, rest); + ecl_va_list args; + cl_object rest; + ecl_va_start(args, format_args, narg, 4); + rest = cl_grab_rest_args(args); + return cl_apply(6, @'si::signal-simple-error', condition, continuable, + format, format_args, rest); } extern cl_object @@ -126,35 +126,35 @@ cl_set_difference(cl_narg narg, cl_object l1, cl_object l2, ...) extern cl_object cl_array_dimensions(cl_object array) { - return _ecl_funcall2(@'ARRAY-DIMENSIONS', array); + return _ecl_funcall2(@'ARRAY-DIMENSIONS', array); } extern cl_object si_find_relative_package(cl_narg narg, cl_object package, ...) { - @(return ECL_NIL); + @(return ECL_NIL); } extern cl_object si_wrong_type_argument(cl_narg narg, cl_object object, cl_object type, ...) { - return _ecl_funcall3(@'si::wrong-type-argument', object, type); + return _ecl_funcall3(@'si::wrong-type-argument', object, type); } extern cl_object si_make_encoding(cl_object mapping) { - return _ecl_funcall2(@'ext::make-encoding', mapping); + return _ecl_funcall2(@'ext::make-encoding', mapping); } static cl_object si_simple_toplevel () { cl_env_ptr env = ecl_process_env(); - cl_object output = cl_core.standard_output; - cl_object sentence; - int i; + cl_object output = cl_core.standard_output; + cl_object sentence; + int i; - /* Simple minded top level loop */ + /* Simple minded top level loop */ ECL_CATCH_ALL_BEGIN(env) { writestr_stream(";*** Lisp core booted ****\n" "ECL (Embeddable Common Lisp)\n", @@ -169,7 +169,7 @@ static cl_object si_simple_toplevel () sentence = @read(3, ECL_NIL, ECL_NIL, OBJNULL); if (sentence == OBJNULL) @(return); - sentence = si_eval_with_env(1, sentence); + sentence = si_eval_with_env(1, sentence); ecl_prin1(sentence, output); } } ECL_CATCH_ALL_END; @@ -178,29 +178,29 @@ static cl_object si_simple_toplevel () int main(int argc, char **args) { - cl_object top_level, features; + cl_object top_level, features; - /* This should be always the first call */ - cl_boot(argc, args); + /* This should be always the first call */ + cl_boot(argc, args); - /* We are computing unnormalized numbers at some point */ - si_trap_fpe(ECL_T, ECL_NIL); + /* We are computing unnormalized numbers at some point */ + si_trap_fpe(ECL_T, ECL_NIL); #ifdef ECL_CMU_FORMAT - ECL_SET(@'*load-verbose*', ECL_NIL); + ECL_SET(@'*load-verbose*', ECL_NIL); #endif - ECL_SET(@'*package*', cl_core.system_package); + ECL_SET(@'*package*', cl_core.system_package); - features = ecl_symbol_value(@'*features*'); - features = CONS(ecl_make_keyword("ECL-MIN"), features); + features = ecl_symbol_value(@'*features*'); + features = CONS(ecl_make_keyword("ECL-MIN"), features); #ifdef HAVE_UNAME - features = CONS(ecl_make_keyword("UNAME"), features); + features = CONS(ecl_make_keyword("UNAME"), features); #endif - ECL_SET(@'*features*', features); - top_level = _ecl_intern("TOP-LEVEL", cl_core.system_package); - ecl_def_c_function(top_level, si_simple_toplevel, 0); - _ecl_funcall1(top_level); - return(0); + ECL_SET(@'*features*', features); + top_level = _ecl_intern("TOP-LEVEL", cl_core.system_package); + ecl_def_c_function(top_level, si_simple_toplevel, 0); + _ecl_funcall1(top_level); + return(0); } #ifdef __cplusplus diff --git a/src/c/clos/accessor.d b/src/c/clos/accessor.d index afb34d464..5027343ef 100644 --- a/src/c/clos/accessor.d +++ b/src/c/clos/accessor.d @@ -22,172 +22,172 @@ static void no_applicable_method(cl_env_ptr env, cl_object gfun, cl_object args) { - env->values[0] = cl_apply(3, @'no-applicable-method', gfun, args); + env->values[0] = cl_apply(3, @'no-applicable-method', gfun, args); } static cl_object fill_spec_vector(cl_object vector, cl_object gfun, cl_object instance) { - cl_object *argtype = vector->vector.self.t; - argtype[0] = gfun; - argtype[1] = ECL_CLASS_OF(instance); - vector->vector.fillp = 2; - return vector; + cl_object *argtype = vector->vector.self.t; + argtype[0] = gfun; + argtype[1] = ECL_CLASS_OF(instance); + vector->vector.fillp = 2; + return vector; } static cl_object slot_method_name(cl_object gfun, cl_object args) { - cl_object methods = _ecl_funcall3(@'compute-applicable-methods', - gfun, args); - unlikely_if (Null(methods)) { - return OBJNULL; - } else { - cl_object first = ECL_CONS_CAR(methods); - cl_object slotd = _ecl_funcall3(@'slot-value', first, - @'clos::slot-definition'); - return _ecl_funcall3(@'slot-value', slotd, @'clos::name'); - } + cl_object methods = _ecl_funcall3(@'compute-applicable-methods', + gfun, args); + unlikely_if (Null(methods)) { + return OBJNULL; + } else { + cl_object first = ECL_CONS_CAR(methods); + cl_object slotd = _ecl_funcall3(@'slot-value', first, + @'clos::slot-definition'); + return _ecl_funcall3(@'slot-value', slotd, @'clos::name'); + } } static cl_object slot_method_index(cl_object gfun, cl_object instance, cl_object args) { - cl_object slot_name = slot_method_name(gfun, args); - unlikely_if (slot_name == OBJNULL) - return OBJNULL; - else { - cl_object table = _ecl_funcall3(@'slot-value', - ECL_CLASS_OF(instance), - @'clos::location-table'); - /* The class might not be a standard class. This happens - * when a nonstandard class inherits from a standard class - * and does not add any new slot accessor. - */ - unlikely_if (Null(table)) - return slot_name; - return ecl_gethash_safe(slot_name, table, OBJNULL); - } + cl_object slot_name = slot_method_name(gfun, args); + unlikely_if (slot_name == OBJNULL) + return OBJNULL; + else { + cl_object table = _ecl_funcall3(@'slot-value', + ECL_CLASS_OF(instance), + @'clos::location-table'); + /* The class might not be a standard class. This happens + * when a nonstandard class inherits from a standard class + * and does not add any new slot accessor. + */ + unlikely_if (Null(table)) + return slot_name; + return ecl_gethash_safe(slot_name, table, OBJNULL); + } } static ecl_cache_record_ptr search_slot_index(const cl_env_ptr env, cl_object gfun, cl_object instance) { - ecl_cache_ptr cache = env->slot_cache; - fill_spec_vector(cache->keys, gfun, instance); - return ecl_search_cache(cache); + ecl_cache_ptr cache = env->slot_cache; + fill_spec_vector(cache->keys, gfun, instance); + return ecl_search_cache(cache); } static ecl_cache_record_ptr add_new_index(const cl_env_ptr env, cl_object gfun, cl_object instance, cl_object args) { - /* The keys and the cache may change while we compute the - * applicable methods. We must save the keys and recompute the - * cache location if it was filled. */ - cl_object index = slot_method_index(gfun, instance, args); - unlikely_if (index == OBJNULL) { - no_applicable_method(env, gfun, args); - return 0; - } - { - ecl_cache_record_ptr e; - ecl_cache_ptr cache = env->slot_cache; - fill_spec_vector(cache->keys, gfun, instance); - e = ecl_search_cache(cache); - e->key = cl_copy_seq(cache->keys); - e->value = index; - return e; - } + /* The keys and the cache may change while we compute the + * applicable methods. We must save the keys and recompute the + * cache location if it was filled. */ + cl_object index = slot_method_index(gfun, instance, args); + unlikely_if (index == OBJNULL) { + no_applicable_method(env, gfun, args); + return 0; + } + { + ecl_cache_record_ptr e; + ecl_cache_ptr cache = env->slot_cache; + fill_spec_vector(cache->keys, gfun, instance); + e = ecl_search_cache(cache); + e->key = cl_copy_seq(cache->keys); + e->value = index; + return e; + } } static void ensure_up_to_date_instance(cl_object instance) { - cl_object clas = ECL_CLASS_OF(instance); - cl_object slots = ECL_CLASS_SLOTS(clas); - unlikely_if (slots != ECL_UNBOUND && instance->instance.sig != slots) { - _ecl_funcall2(@'clos::update-instance', instance); - } + cl_object clas = ECL_CLASS_OF(instance); + cl_object slots = ECL_CLASS_SLOTS(clas); + unlikely_if (slots != ECL_UNBOUND && instance->instance.sig != slots) { + _ecl_funcall2(@'clos::update-instance', instance); + } } cl_object ecl_slot_reader_dispatch(cl_narg narg, cl_object instance) { - const cl_env_ptr env = ecl_process_env(); - cl_object gfun = env->function; - cl_object index, value; - ecl_cache_record_ptr e; + const cl_env_ptr env = ecl_process_env(); + cl_object gfun = env->function; + cl_object index, value; + ecl_cache_record_ptr e; - unlikely_if (narg != 1) - FEwrong_num_arguments(gfun); - unlikely_if (!ECL_INSTANCEP(instance)) { - no_applicable_method(env, gfun, ecl_list1(instance)); - return env->values[0]; - } + unlikely_if (narg != 1) + FEwrong_num_arguments(gfun); + unlikely_if (!ECL_INSTANCEP(instance)) { + no_applicable_method(env, gfun, ecl_list1(instance)); + return env->values[0]; + } - e = search_slot_index(env, gfun, instance); - unlikely_if (e->key == OBJNULL) { - cl_object args = ecl_list1(instance); - e = add_new_index(env, gfun, instance, args); - /* no_applicable_method() was called */ - unlikely_if (e == 0) { - return env->values[0]; - } - } - ensure_up_to_date_instance(instance); - index = e->value; - if (ECL_FIXNUMP(index)) { - value = instance->instance.slots[ecl_fixnum(index)]; - } else if (ecl_unlikely(!ECL_LISTP(index))) { - value = cl_slot_value(instance, index); - } else if (ecl_unlikely(Null(index))) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } else { - value = ECL_CONS_CAR(index); - } - unlikely_if (value == ECL_UNBOUND) { - cl_object slot_name = slot_method_name(gfun, ecl_list1(instance)); - value = _ecl_funcall4(@'slot-unbound', - ECL_CLASS_OF(instance), - instance, - slot_name); - } - @(return value) + e = search_slot_index(env, gfun, instance); + unlikely_if (e->key == OBJNULL) { + cl_object args = ecl_list1(instance); + e = add_new_index(env, gfun, instance, args); + /* no_applicable_method() was called */ + unlikely_if (e == 0) { + return env->values[0]; + } + } + ensure_up_to_date_instance(instance); + index = e->value; + if (ECL_FIXNUMP(index)) { + value = instance->instance.slots[ecl_fixnum(index)]; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + value = cl_slot_value(instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); + } else { + value = ECL_CONS_CAR(index); + } + unlikely_if (value == ECL_UNBOUND) { + cl_object slot_name = slot_method_name(gfun, ecl_list1(instance)); + value = _ecl_funcall4(@'slot-unbound', + ECL_CLASS_OF(instance), + instance, + slot_name); + } + @(return value) } cl_object ecl_slot_writer_dispatch(cl_narg narg, cl_object value, cl_object instance) { - const cl_env_ptr env = ecl_process_env(); - cl_object gfun = env->function; - ecl_cache_record_ptr e; - cl_object index; + const cl_env_ptr env = ecl_process_env(); + cl_object gfun = env->function; + ecl_cache_record_ptr e; + cl_object index; - unlikely_if (narg != 2) { - FEwrong_num_arguments(gfun); - } - unlikely_if (!ECL_INSTANCEP(instance)) { - no_applicable_method(env, gfun, cl_list(2, value, instance)); - return env->values[0]; - } - e = search_slot_index(env, gfun, instance); - unlikely_if (e->key == OBJNULL) { - cl_object args = cl_list(2, value, instance); - e = add_new_index(env, gfun, instance, args); - /* no_applicable_method() was called */ - unlikely_if (e == 0) { - return env->values[0]; - } - } - index = e->value; - if (ECL_FIXNUMP(index)) { - instance->instance.slots[ecl_fixnum(index)] = value; - } else if (ecl_unlikely(!ECL_LISTP(index))) { - clos_slot_value_set(value, instance, index); - } else if (ecl_unlikely(Null(index))) { - FEerror("Error when accessing method cache for ~A", 1, gfun); - } else { - ECL_RPLACA(index, value); - } - @(return value) + unlikely_if (narg != 2) { + FEwrong_num_arguments(gfun); + } + unlikely_if (!ECL_INSTANCEP(instance)) { + no_applicable_method(env, gfun, cl_list(2, value, instance)); + return env->values[0]; + } + e = search_slot_index(env, gfun, instance); + unlikely_if (e->key == OBJNULL) { + cl_object args = cl_list(2, value, instance); + e = add_new_index(env, gfun, instance, args); + /* no_applicable_method() was called */ + unlikely_if (e == 0) { + return env->values[0]; + } + } + index = e->value; + if (ECL_FIXNUMP(index)) { + instance->instance.slots[ecl_fixnum(index)] = value; + } else if (ecl_unlikely(!ECL_LISTP(index))) { + clos_slot_value_set(value, instance, index); + } else if (ecl_unlikely(Null(index))) { + FEerror("Error when accessing method cache for ~A", 1, gfun); + } else { + ECL_RPLACA(index, value); + } + @(return value) } diff --git a/src/c/clos/cache.d b/src/c/clos/cache.d index c6201d24f..492a2750b 100644 --- a/src/c/clos/cache.d +++ b/src/c/clos/cache.d @@ -26,103 +26,103 @@ static void empty_cache(ecl_cache_ptr cache) { - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - cache->generation = 0; - for (i = 0; i < total_size; i+=3) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.t[i+1] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + cache->generation = 0; + for (i = 0; i < total_size; i+=3) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.t[i+1] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } #ifdef ECL_THREADS - cache->clear_list = ECL_NIL; + cache->clear_list = ECL_NIL; #endif } static void clear_one_from_cache(ecl_cache_ptr cache, cl_object target) { - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - for (i = 0; i < total_size; i+=3) { - cl_object key = table->vector.self.t[i]; - if (key != OBJNULL) { - if (target == key->vector.self.t[0]) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } - } - } + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + for (i = 0; i < total_size; i+=3) { + cl_object key = table->vector.self.t[i]; + if (key != OBJNULL) { + if (target == key->vector.self.t[0]) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } + } + } } #ifdef ECL_THREADS static void clear_list_from_cache(ecl_cache_ptr cache) { - cl_object list = ecl_atomic_get(&cache->clear_list); - cl_object table = cache->table; - cl_index i, total_size = table->vector.dim; - for (i = 0; i < total_size; i+=3) { - cl_object key = table->vector.self.t[i]; - if (key != OBJNULL) { - if (ecl_member_eq(key->vector.self.t[0], list)) { - table->vector.self.t[i] = OBJNULL; - table->vector.self.fix[i+2] = 0; - } - } - } + cl_object list = ecl_atomic_get(&cache->clear_list); + cl_object table = cache->table; + cl_index i, total_size = table->vector.dim; + for (i = 0; i < total_size; i+=3) { + cl_object key = table->vector.self.t[i]; + if (key != OBJNULL) { + if (ecl_member_eq(key->vector.self.t[0], list)) { + table->vector.self.t[i] = OBJNULL; + table->vector.self.fix[i+2] = 0; + } + } + } } #endif ecl_cache_ptr ecl_make_cache(cl_index key_size, cl_index cache_size) { - ecl_cache_ptr cache = ecl_alloc(sizeof(struct ecl_cache)); - cache->keys = - si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(key_size), /* Maximum size */ - ECL_T, /* adjustable */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, /* displaced */ - ECL_NIL); - cache->table = - si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(3*cache_size), /* Maximum size */ - ECL_NIL, /* adjustable */ - ECL_NIL, /* fill pointer */ - ECL_NIL, /* displaced */ - ECL_NIL); - empty_cache(cache); - return cache; + ecl_cache_ptr cache = ecl_alloc(sizeof(struct ecl_cache)); + cache->keys = + si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(key_size), /* Maximum size */ + ECL_T, /* adjustable */ + ecl_make_fixnum(0), /* fill pointer */ + ECL_NIL, /* displaced */ + ECL_NIL); + cache->table = + si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(3*cache_size), /* Maximum size */ + ECL_NIL, /* adjustable */ + ECL_NIL, /* fill pointer */ + ECL_NIL, /* displaced */ + ECL_NIL); + empty_cache(cache); + return cache; } void ecl_cache_remove_one(ecl_cache_ptr cache, cl_object first_key) { #ifdef ECL_THREADS - ecl_atomic_push(&cache->clear_list, first_key); + ecl_atomic_push(&cache->clear_list, first_key); #else - clear_one_from_cache(cache, first_key); + clear_one_from_cache(cache, first_key); #endif } static cl_index vector_hash_key(cl_object keys) { - cl_index c, n, a = GOLDEN_RATIO, b = GOLDEN_RATIO; - for (c = 0, n = keys->vector.fillp; n >= 3; ) { - c += keys->vector.self.index[--n]; - b += keys->vector.self.index[--n]; - a += keys->vector.self.index[--n]; - mix(a, b, c); - } - switch (n) { - case 2: b += keys->vector.self.index[--n]; - case 1: a += keys->vector.self.index[--n]; - c += keys->vector.dim; - mix(a,b,c); - } - return c; + cl_index c, n, a = GOLDEN_RATIO, b = GOLDEN_RATIO; + for (c = 0, n = keys->vector.fillp; n >= 3; ) { + c += keys->vector.self.index[--n]; + b += keys->vector.self.index[--n]; + a += keys->vector.self.index[--n]; + mix(a, b, c); + } + switch (n) { + case 2: b += keys->vector.self.index[--n]; + case 1: a += keys->vector.self.index[--n]; + c += keys->vector.dim; + mix(a,b,c); + } + return c; } @@ -135,88 +135,88 @@ ecl_cache_record_ptr ecl_search_cache(ecl_cache_ptr cache) { #ifdef ECL_THREADS - if (!Null(cache->clear_list)) { - clear_list_from_cache(cache); - } + if (!Null(cache->clear_list)) { + clear_list_from_cache(cache); + } #endif { - cl_object table = cache->table; - cl_object keys = cache->keys; - cl_index argno = keys->vector.fillp; - cl_index i = vector_hash_key(keys); - cl_index total_size = table->vector.dim; - cl_fixnum min_gen, gen; - cl_object *min_e; - int k; - i = i % total_size; - i = i - (i % 3); - min_gen = cache->generation; - min_e = 0; - for (k = 20; k--; ) { - cl_object *e = table->vector.self.t + i; - cl_object hkey = RECORD_KEY(e); - if (hkey == OBJNULL) { - min_gen = -1; - min_e = e; - if (RECORD_VALUE(e) == OBJNULL) { - /* This record is not only deleted but empty - * Hence we cannot find our method ahead */ - break; - } - /* Else we only know that the record has been - * delete, but we might find our data ahead. */ - } else if (argno == hkey->vector.fillp) { - cl_index n; - for (n = 0; n < argno; n++) { - if (keys->vector.self.t[n] != - hkey->vector.self.t[n]) - goto NO_MATCH; - } - min_e = e; - goto FOUND; - } else if (min_gen >= 0) { - NO_MATCH: - /* Unless we have found a deleted record, keep - * looking for the oldest record that we can - * overwrite with the new data. */ - gen = RECORD_GEN(e); - if (gen < min_gen) { - min_gen = gen; - min_e = e; - } - } - i += 3; - if (i >= total_size) i = 0; - } - if (min_e == 0) { - ecl_internal_error("search_method_hash"); - } - RECORD_KEY(min_e) = OBJNULL; - cache->generation++; + cl_object table = cache->table; + cl_object keys = cache->keys; + cl_index argno = keys->vector.fillp; + cl_index i = vector_hash_key(keys); + cl_index total_size = table->vector.dim; + cl_fixnum min_gen, gen; + cl_object *min_e; + int k; + i = i % total_size; + i = i - (i % 3); + min_gen = cache->generation; + min_e = 0; + for (k = 20; k--; ) { + cl_object *e = table->vector.self.t + i; + cl_object hkey = RECORD_KEY(e); + if (hkey == OBJNULL) { + min_gen = -1; + min_e = e; + if (RECORD_VALUE(e) == OBJNULL) { + /* This record is not only deleted but empty + * Hence we cannot find our method ahead */ + break; + } + /* Else we only know that the record has been + * delete, but we might find our data ahead. */ + } else if (argno == hkey->vector.fillp) { + cl_index n; + for (n = 0; n < argno; n++) { + if (keys->vector.self.t[n] != + hkey->vector.self.t[n]) + goto NO_MATCH; + } + min_e = e; + goto FOUND; + } else if (min_gen >= 0) { + NO_MATCH: + /* Unless we have found a deleted record, keep + * looking for the oldest record that we can + * overwrite with the new data. */ + gen = RECORD_GEN(e); + if (gen < min_gen) { + min_gen = gen; + min_e = e; + } + } + i += 3; + if (i >= total_size) i = 0; + } + if (min_e == 0) { + ecl_internal_error("search_method_hash"); + } + RECORD_KEY(min_e) = OBJNULL; + cache->generation++; FOUND: - /* - * Once we have reached here, we set the new generation of - * this record and perform a global shift so that the total - * generation number does not become too large and we can - * expire some elements. - */ - gen = cache->generation; - RECORD_GEN_SET(min_e, gen); - if (gen >= total_size/2) { - cl_object *e = table->vector.self.t; - gen = 0.5*gen; - cache->generation -= gen; - for (i = table->vector.dim; i; i-= 3, e += 3) { - cl_fixnum g = RECORD_GEN(e) - gen; - if (g <= 0) { - RECORD_KEY(e) = OBJNULL; - RECORD_VALUE(e) = ECL_NIL; - g = 0; - } - RECORD_GEN_SET(e, g); - } - } - return (ecl_cache_record_ptr)min_e; + /* + * Once we have reached here, we set the new generation of + * this record and perform a global shift so that the total + * generation number does not become too large and we can + * expire some elements. + */ + gen = cache->generation; + RECORD_GEN_SET(min_e, gen); + if (gen >= total_size/2) { + cl_object *e = table->vector.self.t; + gen = 0.5*gen; + cache->generation -= gen; + for (i = table->vector.dim; i; i-= 3, e += 3) { + cl_fixnum g = RECORD_GEN(e) - gen; + if (g <= 0) { + RECORD_KEY(e) = OBJNULL; + RECORD_VALUE(e) = ECL_NIL; + g = 0; + } + RECORD_GEN_SET(e, g); + } + } + return (ecl_cache_record_ptr)min_e; } } diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 8be958f48..27624a6bd 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -22,94 +22,94 @@ cl_object si_specialp(cl_object sym) { - @(return ((ecl_symbol_type(sym) & ecl_stp_special)? ECL_T : ECL_NIL)) + @(return ((ecl_symbol_type(sym) & ecl_stp_special)? ECL_T : ECL_NIL)) } cl_fixnum ecl_ifloor(cl_fixnum x, cl_fixnum y) { - if (y == 0) - FEerror("Zero divizor", 0); - else if (y > 0) - if (x >= 0) - return(x/y); - else - return(-((-x+y-1))/y); - else - if (x >= 0) - return(-((x-y-1)/(-y))); - else - return((-x)/(-y)); + if (y == 0) + FEerror("Zero divizor", 0); + else if (y > 0) + if (x >= 0) + return(x/y); + else + return(-((-x+y-1))/y); + else + if (x >= 0) + return(-((x-y-1)/(-y))); + else + return((-x)/(-y)); } cl_fixnum ecl_imod(cl_fixnum x, cl_fixnum y) { - return(x - ecl_ifloor(x, y)*y); + return(x - ecl_ifloor(x, y)*y); } /* * ---------------------------------------------------------------------- - * Conversions to C + * Conversions to C * ---------------------------------------------------------------------- */ char ecl_to_char(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - return ecl_fixnum(x); - case t_character: - return ECL_CHAR_CODE(x); - default: - FEerror("~S cannot be coerced to a C char.", 1, x); - } + switch (ecl_t_of(x)) { + case t_fixnum: + return ecl_fixnum(x); + case t_character: + return ECL_CHAR_CODE(x); + default: + FEerror("~S cannot be coerced to a C char.", 1, x); + } } cl_fixnum ecl_to_fixnum(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - return fixint(x); -/* case t_character: return (cl_fixnum)ECL_CHAR_CODE(x); */ - case t_ratio: - return (cl_fixnum)ecl_to_double(x); - case t_singlefloat: - return (cl_fixnum)ecl_single_float(x); - case t_doublefloat: - return (cl_fixnum)ecl_double_float(x); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + return fixint(x); +/* case t_character: return (cl_fixnum)ECL_CHAR_CODE(x); */ + case t_ratio: + return (cl_fixnum)ecl_to_double(x); + case t_singlefloat: + return (cl_fixnum)ecl_single_float(x); + case t_doublefloat: + return (cl_fixnum)ecl_double_float(x); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (cl_fixnum)ecl_long_float(x); + case t_longfloat: + return (cl_fixnum)ecl_long_float(x); #endif - default: - FEerror("~S cannot be coerced to a C int.", 1, x); - } + default: + FEerror("~S cannot be coerced to a C int.", 1, x); + } } cl_index ecl_to_unsigned_integer(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - return fixnnint(x); - case t_ratio: - return (cl_index)ecl_to_double(x); - case t_singlefloat: - return (cl_index)ecl_single_float(x); - case t_doublefloat: - return (cl_index)ecl_double_float(x); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + return fixnnint(x); + case t_ratio: + return (cl_index)ecl_to_double(x); + case t_singlefloat: + return (cl_index)ecl_single_float(x); + case t_doublefloat: + return (cl_index)ecl_double_float(x); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (cl_index)ecl_long_float(x); + case t_longfloat: + return (cl_index)ecl_long_float(x); #endif - default: - FEerror("~S cannot be coerced to a C unsigned int.", 1, x); - } + default: + FEerror("~S cannot be coerced to a C unsigned int.", 1, x); + } } int @@ -133,97 +133,97 @@ ecl_aset_bv(cl_object x, cl_index index, int value) void cl_throw(cl_object tag) { - ecl_frame_ptr fr = frs_sch(tag); - if (fr == NULL) - FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); - ecl_unwind(ecl_process_env(), fr); + ecl_frame_ptr fr = frs_sch(tag); + if (fr == NULL) + FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); + ecl_unwind(ecl_process_env(), fr); } void cl_return_from(cl_object block_id, cl_object block_name) { - ecl_frame_ptr fr = frs_sch(block_id); - if (fr == NULL) - FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", - 2, block_name, block_id); - ecl_unwind(ecl_process_env(), fr); + ecl_frame_ptr fr = frs_sch(block_id); + if (fr == NULL) + FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", + 2, block_name, block_id); + ecl_unwind(ecl_process_env(), fr); } void cl_go(cl_object tag_id, cl_object label) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_frame_ptr fr = frs_sch(tag_id); - if (fr == NULL) - FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); - the_env->values[0] = label; - the_env->nvalues = 1; - ecl_unwind(the_env, fr); + const cl_env_ptr the_env = ecl_process_env(); + ecl_frame_ptr fr = frs_sch(tag_id); + if (fr == NULL) + FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); + the_env->values[0] = label; + the_env->nvalues = 1; + ecl_unwind(the_env, fr); } cl_object cl_grab_rest_args(ecl_va_list args) { - cl_object rest = ECL_NIL; - cl_object *r = &rest; - while (args[0].narg) { - *r = ecl_list1(ecl_va_arg(args)); - r = &ECL_CONS_CDR(*r); - } - return rest; + cl_object rest = ECL_NIL; + cl_object *r = &rest; + while (args[0].narg) { + *r = ecl_list1(ecl_va_arg(args)); + r = &ECL_CONS_CDR(*r); + } + return rest; } void cl_parse_key( - ecl_va_list args, /* actual args */ - int nkey, /* number of keywords */ - cl_object *keys, /* keywords for the function */ - cl_object *vars, /* where to put values (vars[0..nkey-1]) - and suppliedp (vars[nkey..2*nkey-1]) */ - cl_object *rest, /* if rest != NULL, where to collect rest values */ - bool allow_other_keys) /* whether other key are allowed */ + ecl_va_list args, /* actual args */ + int nkey, /* number of keywords */ + cl_object *keys, /* keywords for the function */ + cl_object *vars, /* where to put values (vars[0..nkey-1]) + and suppliedp (vars[nkey..2*nkey-1]) */ + cl_object *rest, /* if rest != NULL, where to collect rest values */ + bool allow_other_keys) /* whether other key are allowed */ { - int i; - cl_object supplied_allow_other_keys = OBJNULL; - cl_object unknown_keyword = OBJNULL; + int i; + cl_object supplied_allow_other_keys = OBJNULL; + cl_object unknown_keyword = OBJNULL; - if (rest != NULL) *rest = ECL_NIL; + if (rest != NULL) *rest = ECL_NIL; - for (i = 0; i < 2*nkey; i++) - vars[i] = ECL_NIL; /* default values: NIL, supplied: NIL */ - if (args[0].narg <= 0) return; + for (i = 0; i < 2*nkey; i++) + vars[i] = ECL_NIL; /* default values: NIL, supplied: NIL */ + if (args[0].narg <= 0) return; - for (; args[0].narg > 1; ) { - cl_object keyword = ecl_va_arg(args); - cl_object value = ecl_va_arg(args); - if (ecl_unlikely(!ECL_SYMBOLP(keyword))) - FEprogram_error_noreturn("LAMBDA: Keyword expected, got ~S.", + for (; args[0].narg > 1; ) { + cl_object keyword = ecl_va_arg(args); + cl_object value = ecl_va_arg(args); + if (ecl_unlikely(!ECL_SYMBOLP(keyword))) + FEprogram_error_noreturn("LAMBDA: Keyword expected, got ~S.", 1, keyword); - if (rest != NULL) { - rest = &ECL_CONS_CDR(*rest = ecl_list1(keyword)); - rest = &ECL_CONS_CDR(*rest = ecl_list1(value)); - } - for (i = 0; i < nkey; i++) { - if (keys[i] == keyword) { - if (vars[nkey+i] == ECL_NIL) { - vars[i] = value; - vars[nkey+i] = ECL_T; - } - goto goon; - } - } - /* the key is a new one */ - if (keyword == @':allow-other-keys') { - if (supplied_allow_other_keys == OBJNULL) - supplied_allow_other_keys = value; - } else if (unknown_keyword == OBJNULL) - unknown_keyword = keyword; - goon:; - } - if (ecl_unlikely(args[0].narg != 0)) - FEprogram_error_noreturn("Odd number of keys", 0); - if (ecl_unlikely(unknown_keyword != OBJNULL && !allow_other_keys && + if (rest != NULL) { + rest = &ECL_CONS_CDR(*rest = ecl_list1(keyword)); + rest = &ECL_CONS_CDR(*rest = ecl_list1(value)); + } + for (i = 0; i < nkey; i++) { + if (keys[i] == keyword) { + if (vars[nkey+i] == ECL_NIL) { + vars[i] = value; + vars[nkey+i] = ECL_T; + } + goto goon; + } + } + /* the key is a new one */ + if (keyword == @':allow-other-keys') { + if (supplied_allow_other_keys == OBJNULL) + supplied_allow_other_keys = value; + } else if (unknown_keyword == OBJNULL) + unknown_keyword = keyword; + goon:; + } + if (ecl_unlikely(args[0].narg != 0)) + FEprogram_error_noreturn("Odd number of keys", 0); + if (ecl_unlikely(unknown_keyword != OBJNULL && !allow_other_keys && (supplied_allow_other_keys == ECL_NIL || supplied_allow_other_keys == OBJNULL))) - FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); + FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); } diff --git a/src/c/compiler.d b/src/c/compiler.d index 28a812e13..11d982b62 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -18,7 +18,7 @@ [1] The virtual machine has a word size of 16 bits. Operands and arguments have this very size, so that for instance, a jump - OP_JMP increment + OP_JMP increment takes two words of memory: one for the operator and one for the argument. The interpreter is written with this assumption in mind, but it should be @@ -34,31 +34,31 @@ /********************* EXPORTS *********************/ -#define REGISTER_SPECIALS 1 -#define IGNORE_DECLARATIONS 0 +#define REGISTER_SPECIALS 1 +#define IGNORE_DECLARATIONS 0 /* Flags for the compilation routines: */ /* + Push the output of this form */ -#define FLAG_PUSH 1 +#define FLAG_PUSH 1 /* + Set the output of this form in VALUES */ -#define FLAG_VALUES 2 +#define FLAG_VALUES 2 /* + Set the output of this form in REG0 */ -#define FLAG_REG0 4 +#define FLAG_REG0 4 /* + Search function binding in the global environment */ -#define FLAG_GLOBAL 8 +#define FLAG_GLOBAL 8 /* + Ignore this form */ -#define FLAG_IGNORE 0 -#define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES | FLAG_REG0) +#define FLAG_IGNORE 0 +#define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES | FLAG_REG0) -#define FLAG_EXECUTE 16 -#define FLAG_LOAD 32 -#define FLAG_COMPILE 64 -#define FLAG_ONLY_LOAD 128 +#define FLAG_EXECUTE 16 +#define FLAG_LOAD 32 +#define FLAG_COMPILE 64 +#define FLAG_ONLY_LOAD 128 -#define ENV_RECORD_LOCATION(r) CADDDR(r) +#define ENV_RECORD_LOCATION(r) CADDDR(r) -#define ECL_SPECIAL_VAR_REF -2 -#define ECL_UNDEFINED_VAR_REF -1 +#define ECL_SPECIAL_VAR_REF -2 +#define ECL_UNDEFINED_VAR_REF -1 /********************* PRIVATE ********************/ @@ -140,24 +140,24 @@ static void FEill_formed_input(void) ecl_attr_noreturn; static cl_object pop(cl_object *l) { - cl_object head, list = *l; - unlikely_if (ECL_ATOM(list)) - FEill_formed_input(); - head = ECL_CONS_CAR(list); - *l = ECL_CONS_CDR(list); - return head; + cl_object head, list = *l; + unlikely_if (ECL_ATOM(list)) + FEill_formed_input(); + head = ECL_CONS_CAR(list); + *l = ECL_CONS_CDR(list); + return head; } static cl_object pop_maybe_nil(cl_object *l) { - cl_object head, list = *l; - if (list == ECL_NIL) - return ECL_NIL; - unlikely_if (!ECL_LISTP(list)) - FEill_formed_input(); - head = ECL_CONS_CAR(list); - *l = ECL_CONS_CDR(list); - return head; + cl_object head, list = *l; + if (list == ECL_NIL) + return ECL_NIL; + unlikely_if (!ECL_LISTP(list)) + FEill_formed_input(); + head = ECL_CONS_CAR(list); + *l = ECL_CONS_CDR(list); + return head; } /* ------------------------------ ASSEMBLER ------------------------------ */ @@ -165,9 +165,9 @@ pop_maybe_nil(cl_object *l) { static cl_object asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { const cl_compiler_ptr c_env = env->c_env; - cl_object bytecodes; - cl_index code_size, i; - cl_opcode *code; + cl_object bytecodes; + cl_index code_size, i; + cl_opcode *code; cl_object file = ECL_SYM_VAL(env,@'ext::*source-location*'), position; if (Null(file)) { file = ECL_SYM_VAL(env,@'*load-truename*'); @@ -177,33 +177,33 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { file = cl_car(file); } - /* Save bytecodes from this session in a new vector */ - code_size = current_pc(env) - beginning; - bytecodes = ecl_alloc_object(t_bytecodes); - bytecodes->bytecodes.name = @'si::bytecodes'; + /* Save bytecodes from this session in a new vector */ + code_size = current_pc(env) - beginning; + bytecodes = ecl_alloc_object(t_bytecodes); + bytecodes->bytecodes.name = @'si::bytecodes'; bytecodes->bytecodes.definition = definition; - bytecodes->bytecodes.code_size = code_size; - bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); - bytecodes->bytecodes.data = c_env->constants; - for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { - code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); - } + bytecodes->bytecodes.code_size = code_size; + bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); + bytecodes->bytecodes.data = c_env->constants; + for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { + code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); + } bytecodes->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; ecl_set_function_source_file_info(bytecodes, (file == OBJNULL)? ECL_NIL : file, (file == OBJNULL)? ECL_NIL : position); - asm_clear(env, beginning); - return bytecodes; + asm_clear(env, beginning); + return bytecodes; } #if defined(ECL_SMALL_BYTECODES) static void asm_arg(cl_env_ptr env, int n) { #ifdef WORDS_BIGENDIAN - asm_op(env, (n >> 8) & 0xFF); - asm_op(env, n & 0xFF); + asm_op(env, (n >> 8) & 0xFF); + asm_op(env, n & 0xFF); #else - asm_op(env, n & 0xFF); - asm_op(env, (n >> 8) & 0xFF); + asm_op(env, n & 0xFF); + asm_op(env, (n >> 8) & 0xFF); #endif } #else @@ -223,52 +223,52 @@ asm_clear(cl_env_ptr env, cl_index h) { static void asm_op2(cl_env_ptr env, int code, int n) { - if (ecl_unlikely(n < -MAX_OPARG || MAX_OPARG < n)) - FEprogram_error_noreturn("Argument to bytecode is too large", 0); - asm_op(env, code); - asm_arg(env, n); + if (ecl_unlikely(n < -MAX_OPARG || MAX_OPARG < n)) + FEprogram_error_noreturn("Argument to bytecode is too large", 0); + asm_op(env, code); + asm_arg(env, n); } static cl_index asm_constant(cl_env_ptr env, cl_object c) { const cl_compiler_ptr c_env = env->c_env; - cl_object constants = c_env->constants; - cl_vector_push_extend(2, c, constants); - return constants->vector.fillp-1; + cl_object constants = c_env->constants; + cl_vector_push_extend(2, c, constants); + return constants->vector.fillp-1; } static cl_index asm_jmp(cl_env_ptr env, int op) { - cl_index output; - asm_op(env, op); - output = current_pc(env); - asm_arg(env, 0); - return output; + cl_index output; + asm_op(env, op); + output = current_pc(env); + asm_arg(env, 0); + return output; } static void asm_complete(cl_env_ptr env, int op, cl_index pc) { - cl_fixnum delta = current_pc(env) - pc; /* [1] */ - if (ecl_unlikely(op && (asm_ref(env, pc-1) != op))) - FEprogram_error_noreturn("Non matching codes in ASM-COMPLETE2", 0); - else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) - FEprogram_error_noreturn("Too large jump", 0); - else { + cl_fixnum delta = current_pc(env) - pc; /* [1] */ + if (ecl_unlikely(op && (asm_ref(env, pc-1) != op))) + FEprogram_error_noreturn("Non matching codes in ASM-COMPLETE2", 0); + else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) + FEprogram_error_noreturn("Too large jump", 0); + else { #ifdef ECL_SMALL_BYTECODES - unsigned char low = delta & 0xFF; - char high = delta >> 8; + unsigned char low = delta & 0xFF; + char high = delta >> 8; # ifdef WORDS_BIGENDIAN - env->stack[pc] = (cl_object)(cl_fixnum)high; - env->stack[pc+1] = (cl_object)(cl_fixnum)low; + env->stack[pc] = (cl_object)(cl_fixnum)high; + env->stack[pc+1] = (cl_object)(cl_fixnum)low; # else - env->stack[pc] = (cl_object)(cl_fixnum)low; - env->stack[pc+1] = (cl_object)(cl_fixnum)high; + env->stack[pc] = (cl_object)(cl_fixnum)low; + env->stack[pc+1] = (cl_object)(cl_fixnum)high; # endif #else - env->stack[pc] = (cl_object)(cl_fixnum)delta; + env->stack[pc] = (cl_object)(cl_fixnum)delta; #endif - } + } } /* ------------------------------ COMPILER ------------------------------ */ @@ -343,53 +343,53 @@ static compiler_record database[] = { static void assert_type_symbol(cl_object v) { - if (ecl_t_of(v) != t_symbol) - FEprogram_error_noreturn("Expected a symbol, found ~S.", 1, v); + if (ecl_t_of(v) != t_symbol) + FEprogram_error_noreturn("Expected a symbol, found ~S.", 1, v); } static void FEillegal_variable_name(cl_object v) { - FEprogram_error_noreturn("Not a valid variable name ~S.", 1, v); + FEprogram_error_noreturn("Not a valid variable name ~S.", 1, v); } static void FEill_formed_input() { - FEprogram_error_noreturn("Syntax error: list with too few elements or improperly terminated.", 0); + FEprogram_error_noreturn("Syntax error: list with too few elements or improperly terminated.", 0); } static int c_search_constant(cl_env_ptr env, cl_object c) { const cl_compiler_ptr c_env = env->c_env; - cl_object p = c_env->constants; - int n; - for (n = 0; n < p->vector.fillp; n++) { - if (ecl_eql(p->vector.self.t[n], c)) { - return n; - } - } - return -1; + cl_object p = c_env->constants; + int n; + for (n = 0; n < p->vector.fillp; n++) { + if (ecl_eql(p->vector.self.t[n], c)) { + return n; + } + } + return -1; } static int c_register_constant(cl_env_ptr env, cl_object c) { - int n = c_search_constant(env, c); - return (n < 0)? - asm_constant(env, c) : - n; + int n = c_search_constant(env, c); + return (n < 0)? + asm_constant(env, c) : + n; } static void asm_c(cl_env_ptr env, cl_object o) { - asm_arg(env, c_register_constant(env, o)); + asm_arg(env, c_register_constant(env, o)); } static void asm_op2c(cl_env_ptr env, int code, cl_object o) { - asm_op2(env, code, c_register_constant(env, o)); + asm_op2(env, code, c_register_constant(env, o)); } /* @@ -399,16 +399,16 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * The compiler environment consists of two lists, one stored in * env->variables, the other one stored in env->macros. * - * variable-record = (:block block-name [used-p | block-object] location) | - * (:tag ({tag-name}*) [NIL | tag-object] location) | - * (:function function-name used-p [location]) | - * (var-name {:special | nil} bound-p [location]) | - * (symbol si::symbol-macro macro-function) | - * CB | LB | UNWIND-PROTECT | - * (:declare declaration-arguments*) - * macro-record = (function-name FUNCTION [| function-object]) | - * (macro-name si::macro macro-function) - * CB | LB | UNWIND-PROTECT + * variable-record = (:block block-name [used-p | block-object] location) | + * (:tag ({tag-name}*) [NIL | tag-object] location) | + * (:function function-name used-p [location]) | + * (var-name {:special | nil} bound-p [location]) | + * (symbol si::symbol-macro macro-function) | + * CB | LB | UNWIND-PROTECT | + * (:declare declaration-arguments*) + * macro-record = (function-name FUNCTION [| function-object]) | + * (macro-name si::macro macro-function) + * CB | LB | UNWIND-PROTECT * * A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A * MACRO-FUNCTION is a function that provides us with the expansion @@ -444,7 +444,7 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { static cl_object new_location(const cl_compiler_ptr c_env) { - return CONS(ecl_make_fixnum(c_env->env_depth), + return CONS(ecl_make_fixnum(c_env->env_depth), ecl_make_fixnum(c_env->env_size++)); } #endif @@ -453,44 +453,44 @@ static cl_index c_register_block(cl_env_ptr env, cl_object name) { const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':block', name, ECL_NIL, loc), + cl_object loc = new_location(c_env); + c_env->variables = CONS(cl_list(4, @':block', name, ECL_NIL, loc), c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + return ecl_fixnum(ECL_CONS_CDR(loc)); } static cl_index c_register_tags(cl_env_ptr env, cl_object all_tags) { const cl_compiler_ptr c_env = env->c_env; - cl_object loc = new_location(c_env); - c_env->variables = CONS(cl_list(4, @':tag', all_tags, ECL_NIL, loc), + cl_object loc = new_location(c_env); + c_env->variables = CONS(cl_list(4, @':tag', all_tags, ECL_NIL, loc), c_env->variables); - return ecl_fixnum(ECL_CONS_CDR(loc)); + return ecl_fixnum(ECL_CONS_CDR(loc)); } static void c_register_function(cl_env_ptr env, cl_object name) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, @':function', name, ECL_NIL, + c_env->variables = CONS(cl_list(4, @':function', name, ECL_NIL, new_location(c_env)), c_env->variables); - c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); + c_env->macros = CONS(cl_list(2, name, @'function'), c_env->macros); } static cl_object c_macro_expand1(cl_env_ptr env, cl_object stmt) { const cl_compiler_ptr c_env = env->c_env; - return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); + return cl_macroexpand_1(2, stmt, CONS(c_env->variables, c_env->macros)); } static void c_register_symbol_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), + c_env->variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), c_env->variables); } @@ -499,19 +499,19 @@ static void c_register_macro(cl_env_ptr env, cl_object name, cl_object exp_fun) { const cl_compiler_ptr c_env = env->c_env; - c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); + c_env->macros = CONS(cl_list(3, name, @'si::macro', exp_fun), c_env->macros); } */ static void c_register_var(cl_env_ptr env, cl_object var, bool special, bool bound) { - const cl_compiler_ptr c_env = env->c_env; - c_env->variables = CONS(cl_list(4, var, - special? @'special' : ECL_NIL, - bound? ECL_T : ECL_NIL, - new_location(c_env)), - c_env->variables); + const cl_compiler_ptr c_env = env->c_env; + c_env->variables = CONS(cl_list(4, var, + special? @'special' : ECL_NIL, + bound? ECL_T : ECL_NIL, + new_location(c_env)), + c_env->variables); } static void @@ -519,18 +519,18 @@ guess_environment(cl_env_ptr env, cl_object interpreter_env) { if (!LISTP(interpreter_env)) return; - /* - * Given the environment of an interpreted function, we guess a - * suitable compiler enviroment to compile forms that access the - * variables and local functions of this interpreted code. - */ - for (interpreter_env = @revappend(interpreter_env, ECL_NIL); - !Null(interpreter_env); - interpreter_env = ECL_CONS_CDR(interpreter_env)) - { - cl_object record = ECL_CONS_CAR(interpreter_env); + /* + * Given the environment of an interpreted function, we guess a + * suitable compiler enviroment to compile forms that access the + * variables and local functions of this interpreted code. + */ + for (interpreter_env = @revappend(interpreter_env, ECL_NIL); + !Null(interpreter_env); + interpreter_env = ECL_CONS_CDR(interpreter_env)) + { + cl_object record = ECL_CONS_CAR(interpreter_env); if (!LISTP(record)) { - c_register_function(env, record); + c_register_function(env, record); } else { cl_object record0 = ECL_CONS_CAR(record); cl_object record1 = ECL_CONS_CDR(record); @@ -542,248 +542,248 @@ guess_environment(cl_env_ptr env, cl_object interpreter_env) c_register_block(env, record1); } } - } + } } static void c_new_env(cl_env_ptr the_env, cl_compiler_env_ptr new, cl_object env, cl_compiler_env_ptr old) { - the_env->c_env = new; - if (old) { - *new = *old; - new->env_depth = old->env_depth + 1; - } else { - new->code_walker = ECL_SYM_VAL(the_env, @'si::*code-walker*'); - new->constants = si_make_vector(ECL_T, ecl_make_fixnum(16), - ECL_T, /* Adjustable */ - ecl_make_fixnum(0), /* Fillp */ - ECL_NIL, /* displacement */ - ECL_NIL); - new->stepping = 0; - new->lexical_level = 0; - new->load_time_forms = ECL_NIL; - new->env_depth = 0; - new->macros = CDR(env); - new->variables = CAR(env); - for (env = new->variables; !Null(env); env = CDR(env)) { - cl_object record = CAR(env); - if (ECL_ATOM(record)) - continue; - if (ECL_SYMBOLP(CAR(record)) && CADR(record) != @'si::symbol-macro') { - continue; - } else { - new->lexical_level = 1; - break; - } - } + the_env->c_env = new; + if (old) { + *new = *old; + new->env_depth = old->env_depth + 1; + } else { + new->code_walker = ECL_SYM_VAL(the_env, @'si::*code-walker*'); + new->constants = si_make_vector(ECL_T, ecl_make_fixnum(16), + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); + new->stepping = 0; + new->lexical_level = 0; + new->load_time_forms = ECL_NIL; + new->env_depth = 0; + new->macros = CDR(env); + new->variables = CAR(env); + for (env = new->variables; !Null(env); env = CDR(env)) { + cl_object record = CAR(env); + if (ECL_ATOM(record)) + continue; + if (ECL_SYMBOLP(CAR(record)) && CADR(record) != @'si::symbol-macro') { + continue; + } else { + new->lexical_level = 1; + break; + } + } new->mode = FLAG_EXECUTE; - } - new->env_size = 0; + } + new->env_size = 0; } static cl_object c_tag_ref(cl_env_ptr env, cl_object the_tag, cl_object the_type) { - cl_fixnum n = 0; - cl_object l; + cl_fixnum n = 0; + cl_object l; const cl_compiler_ptr c_env = env->c_env; - for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - cl_object type, name, record = ECL_CONS_CAR(l); - if (ECL_ATOM(record)) - continue; - type = ECL_CONS_CAR(record); + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + cl_object type, name, record = ECL_CONS_CAR(l); + if (ECL_ATOM(record)) + continue; + type = ECL_CONS_CAR(record); record = ECL_CONS_CDR(record); - name = ECL_CONS_CAR(record); - if (type == @':tag') { - if (type == the_type) { - cl_object label = ecl_assql(the_tag, name); - if (!Null(label)) { - return CONS(ecl_make_fixnum(n), ECL_CONS_CDR(label)); - } - } - n++; - } else if (type == @':block' || type == @':function') { - /* We compare with EQUAL, because of (SETF fname) */ - if (type == the_type && ecl_equal(name, the_tag)) { - /* Mark as used */ + name = ECL_CONS_CAR(record); + if (type == @':tag') { + if (type == the_type) { + cl_object label = ecl_assql(the_tag, name); + if (!Null(label)) { + return CONS(ecl_make_fixnum(n), ECL_CONS_CDR(label)); + } + } + n++; + } else if (type == @':block' || type == @':function') { + /* We compare with EQUAL, because of (SETF fname) */ + if (type == the_type && ecl_equal(name, the_tag)) { + /* Mark as used */ record = ECL_CONS_CDR(record); - ECL_RPLACA(record, ECL_T); - return ecl_make_fixnum(n); - } - n++; - } else if (Null(name)) { - n++; - } else { - /* We are counting only locals and ignore specials - * and other declarations */ - } - } - return ECL_NIL; + ECL_RPLACA(record, ECL_T); + return ecl_make_fixnum(n); + } + n++; + } else if (Null(name)) { + n++; + } else { + /* We are counting only locals and ignore specials + * and other declarations */ + } + } + return ECL_NIL; } ecl_def_ct_base_string(undefined_variable, "Undefined variable referenced in interpreted code" - ".~%Name: ~A", 60, static, const); + ".~%Name: ~A", 60, static, const); static cl_fixnum c_var_ref(cl_env_ptr env, cl_object var, int allow_symbol_macro, bool ensure_defined) { - cl_fixnum n = 0; - cl_object l, record, special, name; + cl_fixnum n = 0; + cl_object l, record, special, name; const cl_compiler_ptr c_env = env->c_env; - for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { - record = ECL_CONS_CAR(l); - if (ECL_ATOM(record)) - continue; - name = ECL_CONS_CAR(record); + for (l = c_env->variables; CONSP(l); l = ECL_CONS_CDR(l)) { + record = ECL_CONS_CAR(l); + if (ECL_ATOM(record)) + continue; + name = ECL_CONS_CAR(record); record = ECL_CONS_CDR(record); - special = ECL_CONS_CAR(record); - if (name == @':block' || name == @':tag' || name == @':function') { - n++; - } else if (name == @':declare') { - /* Ignored */ - } else if (name != var) { - /* Symbol not yet found. Only count locals. */ - if (Null(special)) n++; - } else if (special == @'si::symbol-macro') { - /* We can only get here when we try to redefine a - symbol macro */ - if (allow_symbol_macro) - return -1; - FEprogram_error_noreturn("Internal error: symbol macro ~S" + special = ECL_CONS_CAR(record); + if (name == @':block' || name == @':tag' || name == @':function') { + n++; + } else if (name == @':declare') { + /* Ignored */ + } else if (name != var) { + /* Symbol not yet found. Only count locals. */ + if (Null(special)) n++; + } else if (special == @'si::symbol-macro') { + /* We can only get here when we try to redefine a + symbol macro */ + if (allow_symbol_macro) + return -1; + FEprogram_error_noreturn("Internal error: symbol macro ~S" " used as variable", 1, var); - } else if (Null(special)) { - return n; - } else { - return ECL_SPECIAL_VAR_REF; - } - } - if (ensure_defined) { - l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); - if (l != ECL_NIL) { - funcall(3, l, undefined_variable, var); - } - } - return ECL_UNDEFINED_VAR_REF; + } else if (Null(special)) { + return n; + } else { + return ECL_SPECIAL_VAR_REF; + } + } + if (ensure_defined) { + l = ecl_symbol_value(@'ext::*action-on-undefined-variable*'); + if (l != ECL_NIL) { + funcall(3, l, undefined_variable, var); + } + } + return ECL_UNDEFINED_VAR_REF; } static bool c_declared_special(register cl_object var, register cl_object specials) { - return ((ecl_symbol_type(var) & ecl_stp_special) || ecl_member_eq(var, specials)); + return ((ecl_symbol_type(var) & ecl_stp_special) || ecl_member_eq(var, specials)); } static void c_declare_specials(cl_env_ptr env, cl_object specials) { - while (!Null(specials)) { - int ndx; - cl_object var = pop(&specials); - ndx = c_var_ref(env, var, 1, FALSE); - if (ndx >= 0 || ndx == ECL_UNDEFINED_VAR_REF) - c_register_var(env, var, TRUE, FALSE); - } + while (!Null(specials)) { + int ndx; + cl_object var = pop(&specials); + ndx = c_var_ref(env, var, 1, FALSE); + if (ndx >= 0 || ndx == ECL_UNDEFINED_VAR_REF) + c_register_var(env, var, TRUE, FALSE); + } } static cl_object c_process_declarations(cl_object body) { - const cl_env_ptr the_env = ecl_process_env(); - @si::process-declarations(1, body); - body = ecl_nth_value(the_env, 1); - return body; + const cl_env_ptr the_env = ecl_process_env(); + @si::process-declarations(1, body); + body = ecl_nth_value(the_env, 1); + return body; } static bool c_pbind(cl_env_ptr env, cl_object var, cl_object specials) { - bool special; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - else if ((special = c_declared_special(var, specials))) { - c_register_var(env, var, TRUE, TRUE); - asm_op2c(env, OP_PBINDS, var); - } else { - c_register_var(env, var, FALSE, TRUE); - asm_op2c(env, OP_PBIND, var); - } - return special; + bool special; + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + else if ((special = c_declared_special(var, specials))) { + c_register_var(env, var, TRUE, TRUE); + asm_op2c(env, OP_PBINDS, var); + } else { + c_register_var(env, var, FALSE, TRUE); + asm_op2c(env, OP_PBIND, var); + } + return special; } static bool c_bind(cl_env_ptr env, cl_object var, cl_object specials) { - bool special; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - else if ((special = c_declared_special(var, specials))) { - c_register_var(env, var, TRUE, TRUE); - asm_op2c(env, OP_BINDS, var); - } else { - c_register_var(env, var, FALSE, TRUE); - asm_op2c(env, OP_BIND, var); - } - return special; + bool special; + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + else if ((special = c_declared_special(var, specials))) { + c_register_var(env, var, TRUE, TRUE); + asm_op2c(env, OP_BINDS, var); + } else { + c_register_var(env, var, FALSE, TRUE); + asm_op2c(env, OP_BIND, var); + } + return special; } static void c_undo_bindings(cl_env_ptr the_env, cl_object old_vars, int only_specials) { - cl_object env; - cl_index num_lexical = 0; - cl_index num_special = 0; + cl_object env; + cl_index num_lexical = 0; + cl_index num_special = 0; const cl_compiler_ptr c_env = the_env->c_env; - for (env = c_env->variables; env != old_vars && !Null(env); env = ECL_CONS_CDR(env)) - { + for (env = c_env->variables; env != old_vars && !Null(env); env = ECL_CONS_CDR(env)) + { cl_object record, name, special; record = ECL_CONS_CAR(env); - name = ECL_CONS_CAR(record); + name = ECL_CONS_CAR(record); record = ECL_CONS_CDR(record); - special = ECL_CONS_CAR(record); - if (name == @':block' || name == @':tag') { - (void)0; - } else if (name == @':function' || Null(special)) { - if (!only_specials) ++num_lexical; - } else if (name == @':declare') { - /* Ignored */ - } else if (special != @'si::symbol-macro') { - /* If (third special) = NIL, the variable was declared - special, but there is no binding! */ + special = ECL_CONS_CAR(record); + if (name == @':block' || name == @':tag') { + (void)0; + } else if (name == @':function' || Null(special)) { + if (!only_specials) ++num_lexical; + } else if (name == @':declare') { + /* Ignored */ + } else if (special != @'si::symbol-macro') { + /* If (third special) = NIL, the variable was declared + special, but there is no binding! */ record = ECL_CONS_CDR(record); - if (!Null(ECL_CONS_CAR(record))) { - num_special++; - } - } - } - c_env->variables = env; - if (num_lexical) asm_op2(the_env, OP_UNBIND, num_lexical); - if (num_special) asm_op2(the_env, OP_UNBINDS, num_special); + if (!Null(ECL_CONS_CAR(record))) { + num_special++; + } + } + } + c_env->variables = env; + if (num_lexical) asm_op2(the_env, OP_UNBIND, num_lexical); + if (num_special) asm_op2(the_env, OP_UNBINDS, num_special); } static void compile_setq(cl_env_ptr env, int op, cl_object var) { - cl_fixnum ndx; + cl_fixnum ndx; - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - ndx = c_var_ref(env, var,0,TRUE); - if (ndx < 0) { /* Not a lexical variable */ - if (ecl_symbol_type(var) & ecl_stp_constant) { - FEassignment_to_constant(var); - } - ndx = c_register_constant(env, var); - if (op == OP_SETQ) - op = OP_SETQS; - else if (op == OP_PSETQ) - op = OP_PSETQS; - else if (op == OP_VSETQ) - op = OP_VSETQS; - } - asm_op2(env, op, ndx); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + ndx = c_var_ref(env, var,0,TRUE); + if (ndx < 0) { /* Not a lexical variable */ + if (ecl_symbol_type(var) & ecl_stp_constant) { + FEassignment_to_constant(var); + } + ndx = c_register_constant(env, var); + if (op == OP_SETQ) + op = OP_SETQS; + else if (op == OP_PSETQ) + op = OP_PSETQS; + else if (op == OP_VSETQ) + op = OP_VSETQS; + } + asm_op2(env, op, ndx); } /* @@ -791,17 +791,17 @@ compile_setq(cl_env_ptr env, int op, cl_object var) * that do not want to push values onto the stack. Its purpose is to * keep ignorable forms ignored, while preserving the value of useful * forms. Qualitative behavior: - * FLAG_PUSH -> FLAG_VALUES - * FLAG_VALUES -> FLAG_VALUES - * FLAG_REG0 -> FLAG_REG0 - * FLAG_IGNORE -> FLAG_IGNORE + * FLAG_PUSH -> FLAG_VALUES + * FLAG_VALUES -> FLAG_VALUES + * FLAG_REG0 -> FLAG_REG0 + * FLAG_IGNORE -> FLAG_IGNORE */ static int maybe_values_or_reg0(int flags) { - if (flags & FLAG_PUSH) - return (flags | FLAG_VALUES) & ~FLAG_PUSH; - else - return flags; + if (flags & FLAG_PUSH) + return (flags | FLAG_VALUES) & ~FLAG_PUSH; + else + return flags; } /* @@ -809,17 +809,17 @@ maybe_values_or_reg0(int flags) { * that do not want to push values onto the stack, but also do not want * to use REG0 (maybe because the call a nested ecl_interpret()). Ignorable * forms are kept ignored: - * FLAG_PUSH -> FLAG_VALUES - * FLAG_VALUES -> FLAG_VALUES - * FLAG_REG0 -> FLAG_VALUES - * FLAG_IGNORE -> FLAG_IGNORE + * FLAG_PUSH -> FLAG_VALUES + * FLAG_VALUES -> FLAG_VALUES + * FLAG_REG0 -> FLAG_VALUES + * FLAG_IGNORE -> FLAG_IGNORE */ static int maybe_values(int flags) { - if (flags & FLAG_USEFUL) - return (flags & ~(FLAG_PUSH | FLAG_REG0)) | FLAG_VALUES; - else - return flags; + if (flags & FLAG_USEFUL) + return (flags & ~(FLAG_PUSH | FLAG_REG0)) | FLAG_VALUES; + else + return flags; } /* @@ -827,416 +827,416 @@ maybe_values(int flags) { * that do not want to push values onto the stack. Its purpose is to * keep ignorable forms ignored, while preserving the value of useful * forms. Qualitative behavior: - * FLAG_PUSH -> FLAG_REG0 - * FLAG_VALUES -> FLAG_REG0 - * FLAG_REG0 -> FLAG_REG0 - * FLAG_IGNORE -> FLAG_IGNORE + * FLAG_PUSH -> FLAG_REG0 + * FLAG_VALUES -> FLAG_REG0 + * FLAG_REG0 -> FLAG_REG0 + * FLAG_IGNORE -> FLAG_IGNORE */ static int maybe_reg0(int flags) { - if (flags & FLAG_USEFUL) - return (flags & ~(FLAG_VALUES | FLAG_PUSH)) | FLAG_REG0; - else - return flags; + if (flags & FLAG_USEFUL) + return (flags & ~(FLAG_VALUES | FLAG_PUSH)) | FLAG_REG0; + else + return flags; } /* -------------------- THE COMPILER -------------------- */ /* - The OP_BLOCK operator encloses several forms within a block - named BLOCK_NAME, thus catching any OP_RETFROM whose argument - matches BLOCK_NAME. The end of this block is marked both by - the OP_EXIT operator and the LABELZ which is packed within - the OP_BLOCK operator. + The OP_BLOCK operator encloses several forms within a block + named BLOCK_NAME, thus catching any OP_RETFROM whose argument + matches BLOCK_NAME. The end of this block is marked both by + the OP_EXIT operator and the LABELZ which is packed within + the OP_BLOCK operator. - [OP_BLOCK + name + labelz] - .... - OP_EXIT_FRAME - labelz: ... + [OP_BLOCK + name + labelz] + .... + OP_EXIT_FRAME + labelz: ... */ static int c_block(cl_env_ptr env, cl_object body, int old_flags) { - struct cl_compiler_env old_env; - cl_object name = pop(&body); - cl_object block_record; - cl_index labelz, pc, loc, constants; - int flags; + struct cl_compiler_env old_env; + cl_object name = pop(&body); + cl_object block_record; + cl_index labelz, pc, loc, constants; + int flags; - if (!ECL_SYMBOLP(name)) - FEprogram_error_noreturn("BLOCK: Not a valid block name, ~S", 1, name); + if (!ECL_SYMBOLP(name)) + FEprogram_error_noreturn("BLOCK: Not a valid block name, ~S", 1, name); - old_env = *(env->c_env); - constants = old_env.constants->vector.fillp; - pc = current_pc(env); + old_env = *(env->c_env); + constants = old_env.constants->vector.fillp; + pc = current_pc(env); - flags = maybe_values_or_reg0(old_flags); - loc = c_register_block(env, name); - block_record = ECL_CONS_CAR(env->c_env->variables); - if (Null(name)) { - asm_op(env, OP_DO); - } else { - asm_op2c(env, OP_BLOCK, name); - } - labelz = asm_jmp(env, OP_FRAME); - compile_body(env, body, flags); - if (CADDR(block_record) == ECL_NIL) { - /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ - /* We also have to remove the constants we compiled, because */ - /* some of them might be from load-time-value */ - old_env.constants->vector.fillp = constants; - *(env->c_env) = old_env; - set_pc(env, pc); - return compile_body(env, body, old_flags); - } else { - c_undo_bindings(env, old_env.variables, 0); - asm_op(env, OP_EXIT_FRAME); - asm_complete(env, 0, labelz); - return flags; - } + flags = maybe_values_or_reg0(old_flags); + loc = c_register_block(env, name); + block_record = ECL_CONS_CAR(env->c_env->variables); + if (Null(name)) { + asm_op(env, OP_DO); + } else { + asm_op2c(env, OP_BLOCK, name); + } + labelz = asm_jmp(env, OP_FRAME); + compile_body(env, body, flags); + if (CADDR(block_record) == ECL_NIL) { + /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ + /* We also have to remove the constants we compiled, because */ + /* some of them might be from load-time-value */ + old_env.constants->vector.fillp = constants; + *(env->c_env) = old_env; + set_pc(env, pc); + return compile_body(env, body, old_flags); + } else { + c_undo_bindings(env, old_env.variables, 0); + asm_op(env, OP_EXIT_FRAME); + asm_complete(env, 0, labelz); + return flags; + } } /* - There are several ways to invoke functions and to handle the - output arguments. These are + There are several ways to invoke functions and to handle the + output arguments. These are - [OP_CALL + nargs] - function_name + [OP_CALL + nargs] + function_name - [OP_FCALL + nargs] + [OP_FCALL + nargs] - OP_CALL and OP_FCALL leave all arguments in the VALUES() array, - while OP_PCALL and OP_PFCALL leave the first argument in the - stack. + OP_CALL and OP_FCALL leave all arguments in the VALUES() array, + while OP_PCALL and OP_PFCALL leave the first argument in the + stack. - OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the - function, while OP_FCALL and OP_PFCALL use a value from the - stack. + OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the + function, while OP_FCALL and OP_PFCALL use a value from the + stack. */ static int c_arguments(cl_env_ptr env, cl_object args) { - cl_index nargs; - for (nargs = 0; !Null(args); nargs++) { - compile_form(env, pop(&args), FLAG_PUSH); - } - return nargs; + cl_index nargs; + for (nargs = 0; !Null(args); nargs++) { + compile_form(env, pop(&args), FLAG_PUSH); + } + return nargs; } static int asm_function(cl_env_ptr env, cl_object args, int flags); static int c_call(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - cl_index nargs; + cl_object name; + cl_index nargs; - name = pop(&args); - if (name >= (cl_object)cl_symbols - && name < (cl_object)(cl_symbols + cl_num_symbols_in_core)) - { - cl_object f = ECL_SYM_FUN(name); - cl_type t = (f == OBJNULL)? t_other : ecl_t_of(f); - if (t == t_cfunfixed) { - cl_index n = ecl_length(args); - if (f->cfun.narg == 1 && n == 1) { - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2c(env, OP_CALLG1, name); - return FLAG_VALUES; - } else if (f->cfun.narg == 2 && n == 2) { - compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); - args = ECL_CONS_CDR(args); - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2c(env, OP_CALLG2, name); - return FLAG_VALUES; - } - } - } - nargs = c_arguments(env, args); - if (env->c_env->stepping) { - /* When stepping, we only have one opcode to do function - * calls: OP_STEPFCALL. */ - asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); - asm_op2(env, OP_STEPCALL, nargs); - flags = FLAG_VALUES; - } else if (ECL_SYMBOLP(name) && - ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) - { - asm_op2(env, OP_CALLG, nargs); - asm_c(env, name); - flags = FLAG_VALUES; - } else { - /* Fixme!! We can optimize the case of global functions! */ - asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); - asm_op2(env, OP_CALL, nargs); - flags = FLAG_VALUES; - } - return flags; + name = pop(&args); + if (name >= (cl_object)cl_symbols + && name < (cl_object)(cl_symbols + cl_num_symbols_in_core)) + { + cl_object f = ECL_SYM_FUN(name); + cl_type t = (f == OBJNULL)? t_other : ecl_t_of(f); + if (t == t_cfunfixed) { + cl_index n = ecl_length(args); + if (f->cfun.narg == 1 && n == 1) { + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(env, OP_CALLG1, name); + return FLAG_VALUES; + } else if (f->cfun.narg == 2 && n == 2) { + compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(env, OP_CALLG2, name); + return FLAG_VALUES; + } + } + } + nargs = c_arguments(env, args); + if (env->c_env->stepping) { + /* When stepping, we only have one opcode to do function + * calls: OP_STEPFCALL. */ + asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); + asm_op2(env, OP_STEPCALL, nargs); + flags = FLAG_VALUES; + } else if (ECL_SYMBOLP(name) && + ((flags & FLAG_GLOBAL) || Null(c_tag_ref(env, name, @':function')))) + { + asm_op2(env, OP_CALLG, nargs); + asm_c(env, name); + flags = FLAG_VALUES; + } else { + /* Fixme!! We can optimize the case of global functions! */ + asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0); + asm_op2(env, OP_CALL, nargs); + flags = FLAG_VALUES; + } + return flags; } static int c_funcall(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - cl_index nargs; + cl_object name; + cl_index nargs; - name = pop(&args); - if (CONSP(name)) { + name = pop(&args); + if (CONSP(name)) { cl_object kind = ECL_CONS_CAR(name); - if (kind == @'function') { - if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", + if (kind == @'function') { + if (cl_list_length(name) != ecl_make_fixnum(2)) + FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", 1, name); - return c_call(env, CONS(CADR(name), args), flags); - } - if (kind == @'quote') { - if (cl_list_length(name) != ecl_make_fixnum(2)) - FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", + return c_call(env, CONS(CADR(name), args), flags); + } + if (kind == @'quote') { + if (cl_list_length(name) != ecl_make_fixnum(2)) + FEprogram_error_noreturn("FUNCALL: Invalid function name ~S", 1, name); - return c_call(env, CONS(CADR(name), args), flags | FLAG_GLOBAL); - } - } - compile_form(env, name, FLAG_PUSH); - nargs = c_arguments(env, args); - if (env->c_env->stepping) { - asm_op2(env, OP_STEPCALL, nargs); - flags = FLAG_VALUES; - } else { - asm_op2(env, OP_FCALL, nargs); - flags = FLAG_VALUES; - } - asm_op(env, OP_POP1); - return flags; + return c_call(env, CONS(CADR(name), args), flags | FLAG_GLOBAL); + } + } + compile_form(env, name, FLAG_PUSH); + nargs = c_arguments(env, args); + if (env->c_env->stepping) { + asm_op2(env, OP_STEPCALL, nargs); + flags = FLAG_VALUES; + } else { + asm_op2(env, OP_FCALL, nargs); + flags = FLAG_VALUES; + } + asm_op(env, OP_POP1); + return flags; } static int perform_c_case(cl_env_ptr env, cl_object args, int flags) { - cl_object test, clause; + cl_object test, clause; - do { - if (Null(args)) - return compile_body(env, ECL_NIL, flags); - clause = pop(&args); - if (ECL_ATOM(clause)) - FEprogram_error_noreturn("CASE: Illegal clause ~S.",1,clause); - test = pop(&clause); - } while (test == ECL_NIL); + do { + if (Null(args)) + return compile_body(env, ECL_NIL, flags); + clause = pop(&args); + if (ECL_ATOM(clause)) + FEprogram_error_noreturn("CASE: Illegal clause ~S.",1,clause); + test = pop(&clause); + } while (test == ECL_NIL); - if (@'otherwise' == test || test == ECL_T) { - unlikely_if (args != ECL_NIL) { - FEprogram_error_noreturn("CASE: The selector ~A can only appear at the last position.", - 1, test); - } - compile_body(env, clause, flags); - } else { - cl_index labeln, labelz; - if (CONSP(test)) { - cl_index n = ecl_length(test); - while (n-- > 1) { - cl_object v = pop(&test); - asm_op(env, OP_JEQL); - asm_c(env, v); - asm_arg(env, n * (OPCODE_SIZE + OPARG_SIZE * 2) - + OPARG_SIZE); - } - test = ECL_CONS_CAR(test); - } - asm_op(env, OP_JNEQL); - asm_c(env, test); - labeln = current_pc(env); - asm_arg(env, 0); - compile_body(env, clause, flags); - if (Null(args) && !(flags & FLAG_USEFUL)) { - /* Ther is no otherwise. The test has failed and - we need no output value. We simply close jumps. */ - asm_complete(env, 0 & OP_JNEQL, labeln); - } else { - labelz = asm_jmp(env, OP_JMP); - asm_complete(env, 0 & OP_JNEQL, labeln); - perform_c_case(env, args, flags); - asm_complete(env, OP_JMP, labelz); - } - } - return flags; + if (@'otherwise' == test || test == ECL_T) { + unlikely_if (args != ECL_NIL) { + FEprogram_error_noreturn("CASE: The selector ~A can only appear at the last position.", + 1, test); + } + compile_body(env, clause, flags); + } else { + cl_index labeln, labelz; + if (CONSP(test)) { + cl_index n = ecl_length(test); + while (n-- > 1) { + cl_object v = pop(&test); + asm_op(env, OP_JEQL); + asm_c(env, v); + asm_arg(env, n * (OPCODE_SIZE + OPARG_SIZE * 2) + + OPARG_SIZE); + } + test = ECL_CONS_CAR(test); + } + asm_op(env, OP_JNEQL); + asm_c(env, test); + labeln = current_pc(env); + asm_arg(env, 0); + compile_body(env, clause, flags); + if (Null(args) && !(flags & FLAG_USEFUL)) { + /* Ther is no otherwise. The test has failed and + we need no output value. We simply close jumps. */ + asm_complete(env, 0 & OP_JNEQL, labeln); + } else { + labelz = asm_jmp(env, OP_JMP); + asm_complete(env, 0 & OP_JNEQL, labeln); + perform_c_case(env, args, flags); + asm_complete(env, OP_JMP, labelz); + } + } + return flags; } static int c_case(cl_env_ptr env, cl_object clause, int flags) { - compile_form(env, pop(&clause), FLAG_REG0); - return perform_c_case(env, clause, maybe_values_or_reg0(flags)); + compile_form(env, pop(&clause), FLAG_REG0); + return perform_c_case(env, clause, maybe_values_or_reg0(flags)); } /* - The OP_CATCH takes the object in VALUES(0) and uses it to catch - any OP_THROW operation which uses that value as argument. If a - catch occurs, or when all forms have been properly executed, it - jumps to LABELZ. LABELZ is packed within the OP_CATCH operator. - [OP_CATCH + labelz] - ... - "forms to be caught" - ... - OP_EXIT_FRAME - labelz: ... + The OP_CATCH takes the object in VALUES(0) and uses it to catch + any OP_THROW operation which uses that value as argument. If a + catch occurs, or when all forms have been properly executed, it + jumps to LABELZ. LABELZ is packed within the OP_CATCH operator. + [OP_CATCH + labelz] + ... + "forms to be caught" + ... + OP_EXIT_FRAME + labelz: ... */ static int c_catch(cl_env_ptr env, cl_object args, int flags) { - cl_index labelz, loc; - cl_object old_env; + cl_index labelz, loc; + cl_object old_env; - /* Compile evaluation of tag */ - compile_form(env, pop(&args), FLAG_REG0); + /* Compile evaluation of tag */ + compile_form(env, pop(&args), FLAG_REG0); - /* Compile binding of tag */ - old_env = env->c_env->variables; - loc = c_register_block(env, ecl_make_fixnum(0)); - asm_op(env, OP_CATCH); + /* Compile binding of tag */ + old_env = env->c_env->variables; + loc = c_register_block(env, ecl_make_fixnum(0)); + asm_op(env, OP_CATCH); - /* Compile jump point */ - labelz = asm_jmp(env, OP_FRAME); + /* Compile jump point */ + labelz = asm_jmp(env, OP_FRAME); - /* Compile body of CATCH */ - compile_body(env, args, FLAG_VALUES); + /* Compile body of CATCH */ + compile_body(env, args, FLAG_VALUES); - c_undo_bindings(env, old_env, 0); - asm_op(env, OP_EXIT_FRAME); - asm_complete(env, 0, labelz); + c_undo_bindings(env, old_env, 0); + asm_op(env, OP_EXIT_FRAME); + asm_complete(env, 0, labelz); - return FLAG_VALUES; + return FLAG_VALUES; } static int c_compiler_let(cl_env_ptr env, cl_object args, int flags) { - cl_object bindings; - cl_index old_bds_top_index = env->bds_top - env->bds_org; + cl_object bindings; + cl_index old_bds_top_index = env->bds_top - env->bds_org; - for (bindings = pop(&args); !Null(bindings); ) { - cl_object form = pop(&bindings); - cl_object var = pop(&form); - cl_object value = pop_maybe_nil(&form); - ecl_bds_bind(env, var, value); - } - flags = compile_toplevel_body(env, args, flags); - ecl_bds_unwind(env, old_bds_top_index); - return flags; + for (bindings = pop(&args); !Null(bindings); ) { + cl_object form = pop(&bindings); + cl_object var = pop(&form); + cl_object value = pop_maybe_nil(&form); + ecl_bds_bind(env, var, value); + } + flags = compile_toplevel_body(env, args, flags); + ecl_bds_unwind(env, old_bds_top_index); + return flags; } /* - There are three operators which perform explicit jumps, but - almost all other operators use labels in one way or - another. + There are three operators which perform explicit jumps, but + almost all other operators use labels in one way or + another. - 1) Jumps are always relative to the place where the jump label - is retrieved so that if the label is in vector[0], then the - destination is roughly vector + vector[0]. + 1) Jumps are always relative to the place where the jump label + is retrieved so that if the label is in vector[0], then the + destination is roughly vector + vector[0]. - 2) The three jump forms are + 2) The three jump forms are - [OP_JMP + label] ; Unconditional jump - [OP_JNIL + label] ; Jump if VALUES(0) == ECL_NIL - [OP_JT + label] ; Jump if VALUES(0) != ECL_NIL + [OP_JMP + label] ; Unconditional jump + [OP_JNIL + label] ; Jump if VALUES(0) == ECL_NIL + [OP_JT + label] ; Jump if VALUES(0) != ECL_NIL - It is important to remark that both OP_JNIL and OP_JT truncate - the values stack, so that always NVALUES = 1 after performing - any of these operations. + It is important to remark that both OP_JNIL and OP_JT truncate + the values stack, so that always NVALUES = 1 after performing + any of these operations. */ static int c_cond(cl_env_ptr env, cl_object args, int flags) { - cl_object test, clause; - cl_index label_nil, label_exit; + cl_object test, clause; + cl_index label_nil, label_exit; - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - clause = pop(&args); - if (ECL_ATOM(clause)) - FEprogram_error_noreturn("COND: Illegal clause ~S.",1,clause); - test = pop(&clause); - flags = maybe_values_or_reg0(flags); - if (ECL_T == test) { - /* Default sentence. If no forms, just output T. */ - if (Null(clause)) - compile_form(env, ECL_T, flags); - else - compile_body(env, clause, flags); - } else { - /* Compile the test. If no more forms, just output - the first value (this is guaranteed by OP_JT), but make - sure it is stored in the appropriate place. */ - if (Null(args)) { - if (Null(clause)) { - c_values(env, cl_list(1,test), flags); - } else { - compile_form(env, test, FLAG_REG0); - if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); - label_nil = asm_jmp(env, OP_JNIL); - compile_body(env, clause, flags); - asm_complete(env, OP_JNIL, label_nil); - } - } else if (Null(clause)) { - compile_form(env, test, FLAG_REG0); - if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); - label_exit = asm_jmp(env, OP_JT); - c_cond(env, args, flags); - asm_complete(env, OP_JT, label_exit); - } else { - compile_form(env, test, FLAG_REG0); - label_nil = asm_jmp(env, OP_JNIL); - compile_body(env, clause, flags); - label_exit = asm_jmp(env, OP_JMP); - asm_complete(env, OP_JNIL, label_nil); - c_cond(env, args, flags); - asm_complete(env, OP_JMP, label_exit); - } - } - return flags; + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + clause = pop(&args); + if (ECL_ATOM(clause)) + FEprogram_error_noreturn("COND: Illegal clause ~S.",1,clause); + test = pop(&clause); + flags = maybe_values_or_reg0(flags); + if (ECL_T == test) { + /* Default sentence. If no forms, just output T. */ + if (Null(clause)) + compile_form(env, ECL_T, flags); + else + compile_body(env, clause, flags); + } else { + /* Compile the test. If no more forms, just output + the first value (this is guaranteed by OP_JT), but make + sure it is stored in the appropriate place. */ + if (Null(args)) { + if (Null(clause)) { + c_values(env, cl_list(1,test), flags); + } else { + compile_form(env, test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); + label_nil = asm_jmp(env, OP_JNIL); + compile_body(env, clause, flags); + asm_complete(env, OP_JNIL, label_nil); + } + } else if (Null(clause)) { + compile_form(env, test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(env, OP_VALUEREG0); + label_exit = asm_jmp(env, OP_JT); + c_cond(env, args, flags); + asm_complete(env, OP_JT, label_exit); + } else { + compile_form(env, test, FLAG_REG0); + label_nil = asm_jmp(env, OP_JNIL); + compile_body(env, clause, flags); + label_exit = asm_jmp(env, OP_JMP); + asm_complete(env, OP_JNIL, label_nil); + c_cond(env, args, flags); + asm_complete(env, OP_JMP, label_exit); + } + } + return flags; } -/* The OP_DO operator saves the lexical environment and establishes - a NIL block to execute the enclosed forms, which are typically - like the ones shown below. At the exit of the block, either by - means of a OP_RETFROM jump or because of normal termination, - the lexical environment is restored, and all bindings undone. +/* The OP_DO operator saves the lexical environment and establishes + a NIL block to execute the enclosed forms, which are typically + like the ones shown below. At the exit of the block, either by + means of a OP_RETFROM jump or because of normal termination, + the lexical environment is restored, and all bindings undone. - [OP_DO + labelz] - ... ; bindings - [JMP + labelt] - labelb: ... ; body - ... ; stepping forms - labelt: ... ; test form - [JNIL + label] - ... ; output form - OP_EXIT_FRAME - labelz: + [OP_DO + labelz] + ... ; bindings + [JMP + labelt] + labelb: ... ; body + ... ; stepping forms + labelt: ... ; test form + [JNIL + label] + ... ; output form + OP_EXIT_FRAME + labelz: */ static int c_while_until(cl_env_ptr env, cl_object body, int flags, bool is_while) { - cl_object test = pop(&body); - cl_index labelt, labelb; + cl_object test = pop(&body); + cl_index labelt, labelb; - flags = maybe_reg0(flags); + flags = maybe_reg0(flags); - /* Jump to test */ - labelt = asm_jmp(env, OP_JMP); + /* Jump to test */ + labelt = asm_jmp(env, OP_JMP); - /* Compile body */ - labelb = current_pc(env); - c_tagbody(env, body, flags); + /* Compile body */ + labelb = current_pc(env); + c_tagbody(env, body, flags); - /* Compile test */ - asm_complete(env, OP_JMP, labelt); - compile_form(env, test, FLAG_REG0); - asm_op(env, is_while? OP_JT : OP_JNIL); - asm_arg(env, labelb - current_pc(env)); + /* Compile test */ + asm_complete(env, OP_JMP, labelt); + compile_form(env, test, FLAG_REG0); + asm_op(env, is_while? OP_JT : OP_JNIL); + asm_arg(env, labelb - current_pc(env)); - return flags; + return flags; } static int c_while(cl_env_ptr env, cl_object body, int flags) { - return c_while_until(env, body, flags, 1); + return c_while_until(env, body, flags, 1); } static int c_until(cl_env_ptr env, cl_object body, int flags) { - return c_while_until(env, body, flags, 0); + return c_while_until(env, body, flags, 0); } static int @@ -1285,9 +1285,9 @@ eval_when_flags(cl_object situation) static int c_eval_when(cl_env_ptr env, cl_object args, int flags) { cl_object situation_list = pop(&args); - int situation = eval_when_flags(situation_list); + int situation = eval_when_flags(situation_list); const cl_compiler_ptr c_env = env->c_env; - int mode = c_env->mode; + int mode = c_env->mode; if (mode == FLAG_EXECUTE) { if (!when_execute_p(situation)) args = ECL_NIL; @@ -1297,7 +1297,7 @@ c_eval_when(cl_env_ptr env, cl_object args, int flags) { } else if (mode == FLAG_LOAD) { if (when_compile_p(situation)) { env->c_env->mode = FLAG_COMPILE; - execute_each_form(env, args); + execute_each_form(env, args); env->c_env->mode = FLAG_LOAD; if (!when_load_p(situation)) args = ECL_NIL; @@ -1314,337 +1314,337 @@ c_eval_when(cl_env_ptr env, cl_object args, int flags) { args = ECL_NIL; } else { /* FLAG_COMPILE */ if (when_execute_p(situation) || when_compile_p(situation)) { - execute_each_form(env, args); + execute_each_form(env, args); } - args = ECL_NIL; + args = ECL_NIL; } return compile_toplevel_body(env, args, flags); } /* - The OP_FLET/OP_FLABELS operators change the lexical environment - to add a few local functions. + The OP_FLET/OP_FLABELS operators change the lexical environment + to add a few local functions. - [OP_FLET/OP_FLABELS + nfun + fun1] - ... - OP_UNBIND nfun - labelz: + [OP_FLET/OP_FLABELS + nfun + fun1] + ... + OP_UNBIND nfun + labelz: */ static cl_index c_register_functions(cl_env_ptr env, cl_object l) { - cl_index nfun; - for (nfun = 0; !Null(l); nfun++) { - cl_object definition = pop(&l); - cl_object name = pop(&definition); - c_register_function(env, name); - } - return nfun; + cl_index nfun; + for (nfun = 0; !Null(l); nfun++) { + cl_object definition = pop(&l); + cl_object name = pop(&definition); + c_register_function(env, name); + } + return nfun; } static int c_labels_flet(cl_env_ptr env, int op, cl_object args, int flags) { - cl_object l, def_list = pop(&args); - cl_object old_vars = env->c_env->variables; - cl_object old_funs = env->c_env->macros; - cl_index nfun; + cl_object l, def_list = pop(&args); + cl_object old_vars = env->c_env->variables; + cl_object old_funs = env->c_env->macros; + cl_index nfun; - if (ecl_length(def_list) == 0) { - return c_locally(env, args, flags); - } + if (ecl_length(def_list) == 0) { + return c_locally(env, args, flags); + } - /* If compiling a LABELS form, add the function names to the lexical - environment before compiling the functions */ - if (op == OP_FLET) - nfun = ecl_length(def_list); - else - nfun = c_register_functions(env, def_list); + /* If compiling a LABELS form, add the function names to the lexical + environment before compiling the functions */ + if (op == OP_FLET) + nfun = ecl_length(def_list); + else + nfun = c_register_functions(env, def_list); - /* Push the operator (OP_LABELS/OP_FLET) with the number of functions */ - asm_op2(env, op, nfun); + /* Push the operator (OP_LABELS/OP_FLET) with the number of functions */ + asm_op2(env, op, nfun); - /* Compile the local functions now. */ - for (l = def_list; !Null(l); ) { - cl_object definition = pop(&l); - cl_object name = pop(&definition); - cl_object lambda = ecl_make_lambda(env, name, definition); - cl_index c = c_register_constant(env, lambda); - asm_arg(env, c); - } + /* Compile the local functions now. */ + for (l = def_list; !Null(l); ) { + cl_object definition = pop(&l); + cl_object name = pop(&definition); + cl_object lambda = ecl_make_lambda(env, name, definition); + cl_index c = c_register_constant(env, lambda); + asm_arg(env, c); + } - /* If compiling a FLET form, add the function names to the lexical - environment after compiling the functions */ - if (op == OP_FLET) - c_register_functions(env, def_list); + /* If compiling a FLET form, add the function names to the lexical + environment after compiling the functions */ + if (op == OP_FLET) + c_register_functions(env, def_list); - /* Compile the body of the form with the local functions in the lexical - environment. */ - flags = c_locally(env, args, flags); + /* Compile the body of the form with the local functions in the lexical + environment. */ + flags = c_locally(env, args, flags); - /* Restore and return */ - c_undo_bindings(env, old_vars, 0); - env->c_env->macros = old_funs; + /* Restore and return */ + c_undo_bindings(env, old_vars, 0); + env->c_env->macros = old_funs; - return flags; + return flags; } static int c_flet(cl_env_ptr env, cl_object args, int flags) { - return c_labels_flet(env, OP_FLET, args, flags); + return c_labels_flet(env, OP_FLET, args, flags); } /* - There are two operators that produce functions. The first one - is - [OP_FUNCTION + name] - which takes the function binding of SYMBOL. The second one is - OP_CLOSE - interpreted - which encloses the INTERPRETED function in the current lexical - environment. + There are two operators that produce functions. The first one + is + [OP_FUNCTION + name] + which takes the function binding of SYMBOL. The second one is + OP_CLOSE + interpreted + which encloses the INTERPRETED function in the current lexical + environment. */ static int c_function(cl_env_ptr env, cl_object args, int flags) { - cl_object function = pop(&args); - if (!Null(args)) - FEprogram_error_noreturn("FUNCTION: Too many arguments.", 0); - return asm_function(env, function, flags); + cl_object function = pop(&args); + if (!Null(args)) + FEprogram_error_noreturn("FUNCTION: Too many arguments.", 0); + return asm_function(env, function, flags); } static int asm_function(cl_env_ptr env, cl_object function, int flags) { - if (!Null(si_valid_function_name_p(function))) { - cl_object ndx = c_tag_ref(env, function, @':function'); - if (Null(ndx)) { - /* Globally defined function */ - asm_op2c(env, OP_FUNCTION, function); + if (!Null(si_valid_function_name_p(function))) { + cl_object ndx = c_tag_ref(env, function, @':function'); + if (Null(ndx)) { + /* Globally defined function */ + asm_op2c(env, OP_FUNCTION, function); return FLAG_REG0; - } else { - /* Function from a FLET/LABELS form */ - asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); + } else { + /* Function from a FLET/LABELS form */ + asm_op2(env, OP_LFUNCTION, ecl_fixnum(ndx)); return FLAG_REG0; - } - } + } + } if (CONSP(function)) { cl_object kind = ECL_CONS_CAR(function); cl_object body = ECL_CONS_CDR(function); - cl_object name; + cl_object name; if (kind == @'lambda') { - name = ECL_NIL; + name = ECL_NIL; } else if (kind == @'ext::lambda-block') { name = ECL_CONS_CAR(body); body = ECL_CONS_CDR(body); } else { - goto ERROR; - } - { - const cl_compiler_ptr c_env = env->c_env; - asm_op2c(env, - (Null(c_env->variables) && - Null(c_env->macros))? - OP_QUOTE : OP_CLOSE, - ecl_make_lambda(env, name, body)); - } - return FLAG_REG0; + goto ERROR; + } + { + const cl_compiler_ptr c_env = env->c_env; + asm_op2c(env, + (Null(c_env->variables) && + Null(c_env->macros))? + OP_QUOTE : OP_CLOSE, + ecl_make_lambda(env, name, body)); + } + return FLAG_REG0; } ERROR: FEprogram_error_noreturn("FUNCTION: Not a valid argument ~S.", 1, function); - return FLAG_REG0; + return FLAG_REG0; } static int c_go(cl_env_ptr env, cl_object args, int flags) { - cl_object tag = pop(&args); - cl_object info = c_tag_ref(env, tag, @':tag'); - if (Null(info)) - FEprogram_error_noreturn("GO: Unknown tag ~S.", 1, tag); - if (!Null(args)) - FEprogram_error_noreturn("GO: Too many arguments.",0); - asm_op2(env, OP_GO, ecl_fixnum(CAR(info))); - asm_arg(env, ecl_fixnum(CDR(info))); - return flags; + cl_object tag = pop(&args); + cl_object info = c_tag_ref(env, tag, @':tag'); + if (Null(info)) + FEprogram_error_noreturn("GO: Unknown tag ~S.", 1, tag); + if (!Null(args)) + FEprogram_error_noreturn("GO: Too many arguments.",0); + asm_op2(env, OP_GO, ecl_fixnum(CAR(info))); + asm_arg(env, ecl_fixnum(CDR(info))); + return flags; } /* - (if a b) -> (cond (a b)) - (if a b c) -> (cond (a b) (t c)) + (if a b) -> (cond (a b)) + (if a b c) -> (cond (a b) (t c)) */ static int c_if(cl_env_ptr env, cl_object form, int flags) { - cl_object test = pop(&form); - cl_object then = pop(&form); - then = cl_list(2, test, then); - if (Null(form)) { - return c_cond(env, ecl_list1(then), flags); - } else { - return c_cond(env, cl_list(2, then, CONS(ECL_T, form)), flags); - } + cl_object test = pop(&form); + cl_object then = pop(&form); + then = cl_list(2, test, then); + if (Null(form)) { + return c_cond(env, ecl_list1(then), flags); + } else { + return c_cond(env, cl_list(2, then, CONS(ECL_T, form)), flags); + } } static int c_labels(cl_env_ptr env, cl_object args, int flags) { - return c_labels_flet(env, OP_LABELS, args, flags); + return c_labels_flet(env, OP_LABELS, args, flags); } /* - The OP_PUSHENV saves the current lexical environment to allow - several bindings. - OP_PUSHENV - ... ; binding forms - ... ; body - OP_EXIT + The OP_PUSHENV saves the current lexical environment to allow + several bindings. + OP_PUSHENV + ... ; binding forms + ... ; body + OP_EXIT - There are four forms which perform bindings - OP_PBIND name ; Bind NAME in the lexical env. using - ; a value from the stack - OP_PBINDS name ; Bind NAME as special variable using - ; a value from the stack - OP_BIND name ; Bind NAME in the lexical env. using - ; VALUES(0) - OP_BINDS name ; Bind NAME as special variable using - ; VALUES(0) + There are four forms which perform bindings + OP_PBIND name ; Bind NAME in the lexical env. using + ; a value from the stack + OP_PBINDS name ; Bind NAME as special variable using + ; a value from the stack + OP_BIND name ; Bind NAME in the lexical env. using + ; VALUES(0) + OP_BINDS name ; Bind NAME as special variable using + ; VALUES(0) - After a variable has been bound, there are several ways to - refer to it. + After a variable has been bound, there are several ways to + refer to it. - 1) Refer to the n-th variable in the lexical environment - [SYMVAL + n] + 1) Refer to the n-th variable in the lexical environment + [SYMVAL + n] - 2) Refer to the value of a special variable or constant - SYMVALS - name + 2) Refer to the value of a special variable or constant + SYMVALS + name 3) Push the value of the n-th variable of the lexical environment - [PUSHV + n] + [PUSHV + n] - 4) Push the value of a special variable or constant - PUSHVS - name + 4) Push the value of a special variable or constant + PUSHVS + name */ static int c_let_leta(cl_env_ptr env, int op, cl_object args, int flags) { - cl_object bindings, specials, body, l, vars; - cl_object old_variables = env->c_env->variables; + cl_object bindings, specials, body, l, vars; + cl_object old_variables = env->c_env->variables; - bindings = cl_car(args); - body = c_process_declarations(ECL_CONS_CDR(args)); - specials = env->values[3]; + bindings = cl_car(args); + body = c_process_declarations(ECL_CONS_CDR(args)); + specials = env->values[3]; - /* Optimize some common cases */ - switch(ecl_length(bindings)) { - case 0: return c_locally(env, CDR(args), flags); - case 1: op = OP_BIND; break; - } + /* Optimize some common cases */ + switch(ecl_length(bindings)) { + case 0: return c_locally(env, CDR(args), flags); + case 1: op = OP_BIND; break; + } - for (vars=ECL_NIL, l=bindings; !Null(l); ) { - cl_object aux = pop(&l); - cl_object var, value; - if (ECL_ATOM(aux)) { - var = aux; - value = ECL_NIL; - } else { - var = pop(&aux); - value = pop_maybe_nil(&aux); - if (!Null(aux)) - FEprogram_error_noreturn("LET: Ill formed declaration.",0); - } - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (op == OP_PBIND) { - compile_form(env, value, FLAG_PUSH); - vars = CONS(var, vars); - } else { - compile_form(env, value, FLAG_REG0); - c_bind(env, var, specials); - } - } - while (!Null(vars)) - c_pbind(env, pop(&vars), specials); + for (vars=ECL_NIL, l=bindings; !Null(l); ) { + cl_object aux = pop(&l); + cl_object var, value; + if (ECL_ATOM(aux)) { + var = aux; + value = ECL_NIL; + } else { + var = pop(&aux); + value = pop_maybe_nil(&aux); + if (!Null(aux)) + FEprogram_error_noreturn("LET: Ill formed declaration.",0); + } + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + if (op == OP_PBIND) { + compile_form(env, value, FLAG_PUSH); + vars = CONS(var, vars); + } else { + compile_form(env, value, FLAG_REG0); + c_bind(env, var, specials); + } + } + while (!Null(vars)) + c_pbind(env, pop(&vars), specials); - /* We have to register all specials, because in the list - * there might be some variable that is not bound by this LET form - */ - c_declare_specials(env, specials); + /* We have to register all specials, because in the list + * there might be some variable that is not bound by this LET form + */ + c_declare_specials(env, specials); - flags = compile_body(env, body, flags); + flags = compile_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); - return flags; + c_undo_bindings(env, old_variables, 0); + return flags; } static int c_let(cl_env_ptr env, cl_object args, int flags) { - return c_let_leta(env, OP_PBIND, args, flags); + return c_let_leta(env, OP_PBIND, args, flags); } static int c_leta(cl_env_ptr env, cl_object args, int flags) { - return c_let_leta(env, OP_BIND, args, flags); + return c_let_leta(env, OP_BIND, args, flags); } static int c_load_time_value(cl_env_ptr env, cl_object args, int flags) { - const cl_compiler_ptr c_env = env->c_env; - cl_object value; - unlikely_if (Null(args) || cl_cddr(args) != ECL_NIL) - FEprogram_error_noreturn("LOAD-TIME-VALUE: Wrong number of arguments.", 0); - value = ECL_CONS_CAR(args); + const cl_compiler_ptr c_env = env->c_env; + cl_object value; + unlikely_if (Null(args) || cl_cddr(args) != ECL_NIL) + FEprogram_error_noreturn("LOAD-TIME-VALUE: Wrong number of arguments.", 0); + value = ECL_CONS_CAR(args); if (c_env->mode != FLAG_LOAD && c_env->mode != FLAG_ONLY_LOAD) { - value = si_eval_with_env(1, value); - } else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) { - /* Using the form as constant, we force the system to coalesce multiple - * copies of the same load-time-value form */ - c_env->load_time_forms = - ecl_cons(cl_list(3, args, value, ECL_NIL), - c_env->load_time_forms); - value = args; - } - return compile_constant(env, value, flags); + value = si_eval_with_env(1, value); + } else if (ECL_SYMBOLP(value) || ECL_LISTP(value)) { + /* Using the form as constant, we force the system to coalesce multiple + * copies of the same load-time-value form */ + c_env->load_time_forms = + ecl_cons(cl_list(3, args, value, ECL_NIL), + c_env->load_time_forms); + value = args; + } + return compile_constant(env, value, flags); } static int c_locally(cl_env_ptr env, cl_object args, int flags) { - cl_object old_env = env->c_env->variables; + cl_object old_env = env->c_env->variables; - /* First use declarations by declaring special variables... */ - args = c_process_declarations(args); - c_declare_specials(env, env->values[3]); + /* First use declarations by declaring special variables... */ + args = c_process_declarations(args); + c_declare_specials(env, env->values[3]); - /* ...and then process body */ - flags = compile_toplevel_body(env, args, flags); + /* ...and then process body */ + flags = compile_toplevel_body(env, args, flags); - c_undo_bindings(env, old_env, 0); + c_undo_bindings(env, old_env, 0); - return flags; + return flags; } /* - MACROLET + MACROLET - The current lexical environment is saved. A new one is prepared with - the definitions of these macros, and this environment is used to - compile the body. + The current lexical environment is saved. A new one is prepared with + the definitions of these macros, and this environment is used to + compile the body. */ static int c_macrolet(cl_env_ptr the_env, cl_object args, int flags) { const cl_compiler_ptr c_env = the_env->c_env; - cl_object old_env = c_env->macros; - cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args), - CONS(c_env->variables, c_env->macros)); - c_env->macros = CDR(env); - flags = c_locally(the_env, args, flags); - c_env->macros = old_env; - return flags; + cl_object old_env = c_env->macros; + cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args), + CONS(c_env->variables, c_env->macros)); + c_env->macros = CDR(env); + flags = c_locally(the_env, args, flags); + c_env->macros = old_env; + return flags; } static void @@ -1671,9 +1671,9 @@ c_vbind(cl_env_ptr env, cl_object var, int n, cl_object specials) static int c_multiple_value_bind(cl_env_ptr env, cl_object args, int flags) { - cl_object vars = pop(&args); + cl_object vars = pop(&args); int n = ecl_length(vars); - switch (n) { + switch (n) { case 0: return c_locally(env, args, flags); case 1: @@ -1686,471 +1686,471 @@ c_multiple_value_bind(cl_env_ptr env, cl_object args, int flags) cl_object body = c_process_declarations(args); cl_object specials = env->values[3]; compile_form(env, value, FLAG_VALUES); - for (vars=cl_reverse(vars); n--; ) { - cl_object var = pop(&vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); + for (vars=cl_reverse(vars); n--; ) { + cl_object var = pop(&vars); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); c_vbind(env, var, n, specials); - } - c_declare_specials(env, specials); - flags = compile_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); + } + c_declare_specials(env, specials); + flags = compile_body(env, body, flags); + c_undo_bindings(env, old_variables, 0); return flags; - }} + }} } static int c_multiple_value_call(cl_env_ptr env, cl_object args, int flags) { - cl_object name; - int op; + cl_object name; + int op; - name = pop(&args); - if (Null(args)) { - /* If no arguments, just use ordinary call */ - return c_funcall(env, cl_list(1, name), flags); - } - compile_form(env, name, FLAG_PUSH); - for (op = OP_PUSHVALUES; !Null(args); op = OP_PUSHMOREVALUES) { - compile_form(env, pop(&args), FLAG_VALUES); - asm_op(env, op); - } - asm_op(env, OP_MCALL); - asm_op(env, OP_POP1); + name = pop(&args); + if (Null(args)) { + /* If no arguments, just use ordinary call */ + return c_funcall(env, cl_list(1, name), flags); + } + compile_form(env, name, FLAG_PUSH); + for (op = OP_PUSHVALUES; !Null(args); op = OP_PUSHMOREVALUES) { + compile_form(env, pop(&args), FLAG_VALUES); + asm_op(env, op); + } + asm_op(env, OP_MCALL); + asm_op(env, OP_POP1); - return FLAG_VALUES; + return FLAG_VALUES; } static int c_multiple_value_prog1(cl_env_ptr env, cl_object args, int flags) { - compile_form(env, pop(&args), FLAG_VALUES); - if (!Null(args)) { - asm_op(env, OP_PUSHVALUES); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_POPVALUES); - } - return FLAG_VALUES; + compile_form(env, pop(&args), FLAG_VALUES); + if (!Null(args)) { + asm_op(env, OP_PUSHVALUES); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_POPVALUES); + } + return FLAG_VALUES; } static int c_multiple_value_setq(cl_env_ptr env, cl_object orig_args, int flags) { - cl_object args = orig_args; - cl_object orig_vars; - cl_object vars = ECL_NIL, values; - cl_object old_variables = env->c_env->variables; - cl_index nvars = 0; + cl_object args = orig_args; + cl_object orig_vars; + cl_object vars = ECL_NIL, values; + cl_object old_variables = env->c_env->variables; + cl_index nvars = 0; - /* Look for symbol macros, building the list of variables - and the list of late assignments. */ - for (orig_vars = pop(&args); !Null(orig_vars); ) { - cl_object v = pop(&orig_vars); - if (!ECL_SYMBOLP(v)) - FEillegal_variable_name(v); - v = c_macro_expand1(env, v); - if (!ECL_SYMBOLP(v)) { - /* If any of the places to be set is not a variable, - * transform MULTIPLE-VALUE-SETQ into (SETF (VALUES ...)) - */ - args = orig_args; - return compile_form(env, cl_listX(3, @'setf', + /* Look for symbol macros, building the list of variables + and the list of late assignments. */ + for (orig_vars = pop(&args); !Null(orig_vars); ) { + cl_object v = pop(&orig_vars); + if (!ECL_SYMBOLP(v)) + FEillegal_variable_name(v); + v = c_macro_expand1(env, v); + if (!ECL_SYMBOLP(v)) { + /* If any of the places to be set is not a variable, + * transform MULTIPLE-VALUE-SETQ into (SETF (VALUES ...)) + */ + args = orig_args; + return compile_form(env, cl_listX(3, @'setf', CONS(@'values', CAR(args)), CDR(args)), - flags); - } - vars = CONS(v, vars); - nvars++; - } + flags); + } + vars = CONS(v, vars); + nvars++; + } - /* Compile values */ - values = pop(&args); - if (args != ECL_NIL) - FEprogram_error_noreturn("MULTIPLE-VALUE-SETQ: Too many arguments.", 0); - if (nvars == 0) { - /* No variables */ - return compile_form(env, cl_list(2, @'values', values), flags); - } - compile_form(env, values, FLAG_VALUES); + /* Compile values */ + values = pop(&args); + if (args != ECL_NIL) + FEprogram_error_noreturn("MULTIPLE-VALUE-SETQ: Too many arguments.", 0); + if (nvars == 0) { + /* No variables */ + return compile_form(env, cl_list(2, @'values', values), flags); + } + compile_form(env, values, FLAG_VALUES); - /* Compile variables */ - for (nvars = 0, vars = cl_nreverse(vars); vars != ECL_NIL; nvars++, vars = ECL_CONS_CDR(vars)) { - if (nvars) { - compile_setq(env, OP_VSETQ, ECL_CONS_CAR(vars)); - asm_arg(env, nvars); - } else { - compile_setq(env, OP_SETQ, ECL_CONS_CAR(vars)); - } - } + /* Compile variables */ + for (nvars = 0, vars = cl_nreverse(vars); vars != ECL_NIL; nvars++, vars = ECL_CONS_CDR(vars)) { + if (nvars) { + compile_setq(env, OP_VSETQ, ECL_CONS_CAR(vars)); + asm_arg(env, nvars); + } else { + compile_setq(env, OP_SETQ, ECL_CONS_CAR(vars)); + } + } - c_undo_bindings(env, old_variables, 0); + c_undo_bindings(env, old_variables, 0); - return FLAG_REG0; + return FLAG_REG0; } /* - The OP_NOT operator reverses the boolean value of VALUES(0). + The OP_NOT operator reverses the boolean value of VALUES(0). */ static int c_not(cl_env_ptr env, cl_object args, int flags) { - flags = maybe_reg0(flags); - if (flags & FLAG_USEFUL) { - /* The value is useful */ - compile_form(env, pop(&args), FLAG_REG0); - asm_op(env, OP_NOT); - } else { - /* The value may be ignored. */ - flags = compile_form(env, pop(&args), flags); - } - if (!Null(args)) - FEprogram_error_noreturn("NOT/NULL: Too many arguments.", 0); - return flags; + flags = maybe_reg0(flags); + if (flags & FLAG_USEFUL) { + /* The value is useful */ + compile_form(env, pop(&args), FLAG_REG0); + asm_op(env, OP_NOT); + } else { + /* The value may be ignored. */ + flags = compile_form(env, pop(&args), flags); + } + if (!Null(args)) + FEprogram_error_noreturn("NOT/NULL: Too many arguments.", 0); + return flags; } /* - The OP_NTHVAL operator moves a value from VALUES(ndx) to - VALUES(0). The index NDX is taken from the stack. + The OP_NTHVAL operator moves a value from VALUES(ndx) to + VALUES(0). The index NDX is taken from the stack. - OP_NTHVAL + OP_NTHVAL */ static int c_nth_value(cl_env_ptr env, cl_object args, int flags) { - compile_form(env, pop(&args), FLAG_PUSH); /* INDEX */ - compile_form(env, pop(&args), FLAG_VALUES); /* VALUES */ - if (args != ECL_NIL) - FEprogram_error_noreturn("NTH-VALUE: Too many arguments.",0); - asm_op(env, OP_NTHVAL); - return FLAG_REG0; + compile_form(env, pop(&args), FLAG_PUSH); /* INDEX */ + compile_form(env, pop(&args), FLAG_VALUES); /* VALUES */ + if (args != ECL_NIL) + FEprogram_error_noreturn("NTH-VALUE: Too many arguments.",0); + asm_op(env, OP_NTHVAL); + return FLAG_REG0; } static int c_prog1(cl_env_ptr env, cl_object args, int flags) { - cl_object form = pop(&args); - if (!(flags & FLAG_USEFUL) || (flags & FLAG_PUSH)) { - flags = compile_form(env, form, flags); - compile_body(env, args, FLAG_IGNORE); - } else { - flags = FLAG_REG0; - compile_form(env, form, FLAG_PUSH); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_POP); - } - return flags; + cl_object form = pop(&args); + if (!(flags & FLAG_USEFUL) || (flags & FLAG_PUSH)) { + flags = compile_form(env, form, flags); + compile_body(env, args, FLAG_IGNORE); + } else { + flags = FLAG_REG0; + compile_form(env, form, FLAG_PUSH); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_POP); + } + return flags; } /* - The OP_PROGV operator exectures a set of statements in a lexical - environment that has been extended with special variables. The - list of special variables is taken from the top of the stack, - while the list of values is in VALUES(0). + The OP_PROGV operator exectures a set of statements in a lexical + environment that has been extended with special variables. The + list of special variables is taken from the top of the stack, + while the list of values is in VALUES(0). - ... ; list of variables - OP_PUSH - ... ; list of values - OP_PROGV - ... ; body of progv - OP_EXIT + ... ; list of variables + OP_PUSH + ... ; list of values + OP_PROGV + ... ; body of progv + OP_EXIT */ static int c_progv(cl_env_ptr env, cl_object args, int flags) { - cl_object vars = pop(&args); - cl_object values = pop(&args); + cl_object vars = pop(&args); + cl_object values = pop(&args); - /* The list of variables is in the stack */ - compile_form(env, vars, FLAG_PUSH); + /* The list of variables is in the stack */ + compile_form(env, vars, FLAG_PUSH); - /* The list of values is in reg0 */ - compile_form(env, values, FLAG_REG0); + /* The list of values is in reg0 */ + compile_form(env, values, FLAG_REG0); - /* The body is interpreted within an extended lexical - environment. However, as all the new variables are - special, the compiler need not take care of them - */ - asm_op(env, OP_PROGV); - flags = compile_body(env, args, FLAG_VALUES); - asm_op(env, OP_EXIT_PROGV); + /* The body is interpreted within an extended lexical + environment. However, as all the new variables are + special, the compiler need not take care of them + */ + asm_op(env, OP_PROGV); + flags = compile_body(env, args, FLAG_VALUES); + asm_op(env, OP_EXIT_PROGV); - return flags; + return flags; } /* - There are four assignment operators. They are + There are four assignment operators. They are - 1) Assign VALUES(0) to the lexical variable which occupies the - N-th position - [OP_SETQ + n] + 1) Assign VALUES(0) to the lexical variable which occupies the + N-th position + [OP_SETQ + n] - 2) Assign VALUES(0) to the special variable NAME - [OP_SETQS + name] + 2) Assign VALUES(0) to the special variable NAME + [OP_SETQS + name] - 3) Pop a value from the stack and assign it to the lexical - variable in the N-th position. - [OP_PSETQ + n] + 3) Pop a value from the stack and assign it to the lexical + variable in the N-th position. + [OP_PSETQ + n] - 4) Pop a value from the stack and assign it to the special - variable denoted by NAME - [OP_PSETQS + name] + 4) Pop a value from the stack and assign it to the special + variable denoted by NAME + [OP_PSETQS + name] */ static int c_psetq(cl_env_ptr env, cl_object old_args, int flags) { - cl_object args = ECL_NIL, vars = ECL_NIL; - bool use_psetf = FALSE; - cl_index nvars = 0; + cl_object args = ECL_NIL, vars = ECL_NIL; + bool use_psetf = FALSE; + cl_index nvars = 0; - if (Null(old_args)) - return compile_body(env, ECL_NIL, flags); - /* We have to make sure that non of the variables which - are to be assigned is actually a symbol macro. If that - is the case, we invoke (PSETF ...) to handle the - macro expansions. - */ - do { - cl_object var = pop(&old_args); - cl_object value = pop(&old_args); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - var = c_macro_expand1(env, var); - if (!ECL_SYMBOLP(var)) - use_psetf = TRUE; - args = ecl_nconc(args, cl_list(2, var, value)); - nvars++; - } while (!Null(old_args)); - if (use_psetf) { - return compile_form(env, CONS(@'psetf', args), flags); - } - do { - cl_object var = pop(&args); - cl_object value = pop(&args); - vars = CONS(var, vars); - compile_form(env, value, FLAG_PUSH); - } while (!Null(args)); - do { - compile_setq(env, OP_PSETQ, pop(&vars)); + if (Null(old_args)) + return compile_body(env, ECL_NIL, flags); + /* We have to make sure that non of the variables which + are to be assigned is actually a symbol macro. If that + is the case, we invoke (PSETF ...) to handle the + macro expansions. + */ + do { + cl_object var = pop(&old_args); + cl_object value = pop(&old_args); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + var = c_macro_expand1(env, var); + if (!ECL_SYMBOLP(var)) + use_psetf = TRUE; + args = ecl_nconc(args, cl_list(2, var, value)); + nvars++; + } while (!Null(old_args)); + if (use_psetf) { + return compile_form(env, CONS(@'psetf', args), flags); + } + do { + cl_object var = pop(&args); + cl_object value = pop(&args); + vars = CONS(var, vars); + compile_form(env, value, FLAG_PUSH); + } while (!Null(args)); + do { + compile_setq(env, OP_PSETQ, pop(&vars)); } while (!Null(vars)); - return compile_form(env, ECL_NIL, flags); + return compile_form(env, ECL_NIL, flags); } /* - The OP_RETFROM operator returns from a block using the objects - in VALUES() as output values. + The OP_RETFROM operator returns from a block using the objects + in VALUES() as output values. - ... ; output form - OP_RETFROM - tag ; object which names the block + ... ; output form + OP_RETFROM + tag ; object which names the block */ static int c_return_aux(cl_env_ptr env, cl_object name, cl_object stmt, int flags) { - cl_object ndx = c_tag_ref(env, name, @':block'); - cl_object output = pop_maybe_nil(&stmt); + cl_object ndx = c_tag_ref(env, name, @':block'); + cl_object output = pop_maybe_nil(&stmt); - if (!ECL_SYMBOLP(name) || Null(ndx)) - FEprogram_error_noreturn("RETURN-FROM: Unknown block name ~S.", 1, name); - if (stmt != ECL_NIL) - FEprogram_error_noreturn("RETURN-FROM: Too many arguments.", 0); - compile_form(env, output, FLAG_VALUES); - asm_op2(env, OP_RETURN, ecl_fixnum(ndx)); - return FLAG_VALUES; + if (!ECL_SYMBOLP(name) || Null(ndx)) + FEprogram_error_noreturn("RETURN-FROM: Unknown block name ~S.", 1, name); + if (stmt != ECL_NIL) + FEprogram_error_noreturn("RETURN-FROM: Too many arguments.", 0); + compile_form(env, output, FLAG_VALUES); + asm_op2(env, OP_RETURN, ecl_fixnum(ndx)); + return FLAG_VALUES; } static int c_return(cl_env_ptr env, cl_object stmt, int flags) { - return c_return_aux(env, ECL_NIL, stmt, flags); + return c_return_aux(env, ECL_NIL, stmt, flags); } static int c_return_from(cl_env_ptr env, cl_object stmt, int flags) { - cl_object name = pop(&stmt); - return c_return_aux(env, name, stmt, flags); + cl_object name = pop(&stmt); + return c_return_aux(env, name, stmt, flags); } static int c_setq(cl_env_ptr env, cl_object args, int flags) { - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - do { - cl_object var = pop(&args); - cl_object value = pop(&args); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - var = c_macro_expand1(env, var); - if (ECL_SYMBOLP(var)) { - flags = FLAG_REG0; - compile_form(env, value, FLAG_REG0); - compile_setq(env, OP_SETQ, var); - } else { - flags = ecl_endp(args)? FLAG_VALUES : FLAG_REG0; - compile_form(env, cl_list(3, @'setf', var, value), flags); - } - } while (!Null(args)); - return flags; + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + do { + cl_object var = pop(&args); + cl_object value = pop(&args); + if (!ECL_SYMBOLP(var)) + FEillegal_variable_name(var); + var = c_macro_expand1(env, var); + if (ECL_SYMBOLP(var)) { + flags = FLAG_REG0; + compile_form(env, value, FLAG_REG0); + compile_setq(env, OP_SETQ, var); + } else { + flags = ecl_endp(args)? FLAG_VALUES : FLAG_REG0; + compile_form(env, cl_list(3, @'setf', var, value), flags); + } + } while (!Null(args)); + return flags; } static int c_symbol_macrolet(cl_env_ptr env, cl_object args, int flags) { - cl_object def_list, specials, body; - cl_object old_variables = env->c_env->variables; + cl_object def_list, specials, body; + cl_object old_variables = env->c_env->variables; - def_list = pop(&args); - body = c_process_declarations(args); - specials = env->values[3]; + def_list = pop(&args); + body = c_process_declarations(args); + specials = env->values[3]; - /* Scan the list of definitions */ - while (!Null(def_list)) { - cl_object definition = pop(&def_list); - cl_object name = pop(&definition); - cl_object expansion = pop(&definition); - cl_object arglist = cl_list(2, @gensym(0), @gensym(0)); - cl_object function; - if ((ecl_symbol_type(name) & (ecl_stp_constant|ecl_stp_special)) || + /* Scan the list of definitions */ + while (!Null(def_list)) { + cl_object definition = pop(&def_list); + cl_object name = pop(&definition); + cl_object expansion = pop(&definition); + cl_object arglist = cl_list(2, @gensym(0), @gensym(0)); + cl_object function; + if ((ecl_symbol_type(name) & (ecl_stp_constant|ecl_stp_special)) || ecl_member_eq(name, specials)) - { - FEprogram_error_noreturn("SYMBOL-MACROLET: Symbol ~A cannot be \ + { + FEprogram_error_noreturn("SYMBOL-MACROLET: Symbol ~A cannot be \ declared special and appear in a symbol-macrolet.", 1, name); - } - definition = cl_list(2, arglist, cl_list(2, @'quote', expansion)); - function = ecl_make_lambda(env, name, definition); - c_register_symbol_macro(env, name, function); - } - c_declare_specials(env, specials); - flags = compile_toplevel_body(env, body, flags); - c_undo_bindings(env, old_variables, 0); - return flags; + } + definition = cl_list(2, arglist, cl_list(2, @'quote', expansion)); + function = ecl_make_lambda(env, name, definition); + c_register_symbol_macro(env, name, function); + } + c_declare_specials(env, specials); + flags = compile_toplevel_body(env, body, flags); + c_undo_bindings(env, old_variables, 0); + return flags; } static int c_tagbody(cl_env_ptr env, cl_object args, int flags) { - cl_object old_env = env->c_env->variables; - cl_index tag_base; - cl_object labels = ECL_NIL, label, body; - cl_type item_type; - int nt, i; + cl_object old_env = env->c_env->variables; + cl_index tag_base; + cl_object labels = ECL_NIL, label, body; + cl_type item_type; + int nt, i; - /* count the tags */ - for (nt = 0, body = args; !Null(body); ) { - label = pop(&body); - item_type = ecl_t_of(label); - if (item_type == t_symbol || item_type == t_fixnum || - item_type == t_bignum) { - labels = CONS(CONS(label,ecl_make_fixnum(nt)), labels); - nt += 1; - } - } - if (nt == 0) { - compile_body(env, args, 0); - return compile_form(env, ECL_NIL, flags); - } - asm_op2c(env, OP_BLOCK, ecl_make_fixnum(0)); - c_register_tags(env, labels); - asm_op2(env, OP_TAGBODY, nt); - tag_base = current_pc(env); - for (i = nt; i; i--) - asm_arg(env, 0); + /* count the tags */ + for (nt = 0, body = args; !Null(body); ) { + label = pop(&body); + item_type = ecl_t_of(label); + if (item_type == t_symbol || item_type == t_fixnum || + item_type == t_bignum) { + labels = CONS(CONS(label,ecl_make_fixnum(nt)), labels); + nt += 1; + } + } + if (nt == 0) { + compile_body(env, args, 0); + return compile_form(env, ECL_NIL, flags); + } + asm_op2c(env, OP_BLOCK, ecl_make_fixnum(0)); + c_register_tags(env, labels); + asm_op2(env, OP_TAGBODY, nt); + tag_base = current_pc(env); + for (i = nt; i; i--) + asm_arg(env, 0); - for (body = args; !Null(body); ) { - label = pop(&body); - item_type = ecl_t_of(label); - if (item_type == t_symbol || item_type == t_fixnum || - item_type == t_bignum) { - asm_complete(env, 0, tag_base); - tag_base += OPARG_SIZE; - } else { - compile_form(env, label, FLAG_IGNORE); - } - } - asm_op(env, OP_EXIT_TAGBODY); - c_undo_bindings(env, old_env, 0); - return FLAG_REG0; + for (body = args; !Null(body); ) { + label = pop(&body); + item_type = ecl_t_of(label); + if (item_type == t_symbol || item_type == t_fixnum || + item_type == t_bignum) { + asm_complete(env, 0, tag_base); + tag_base += OPARG_SIZE; + } else { + compile_form(env, label, FLAG_IGNORE); + } + } + asm_op(env, OP_EXIT_TAGBODY); + c_undo_bindings(env, old_env, 0); + return FLAG_REG0; } static int c_the(cl_env_ptr env, cl_object stmt, int flags) { - cl_object type = pop(&stmt); - cl_object value = pop(&stmt); - if (stmt != ECL_NIL) { - FEprogram_error_noreturn("THE: Too many arguments",0); - } - return compile_form(env, value, flags); + cl_object type = pop(&stmt); + cl_object value = pop(&stmt); + if (stmt != ECL_NIL) { + FEprogram_error_noreturn("THE: Too many arguments",0); + } + return compile_form(env, value, flags); } /* - The OP_THROW jumps to an enclosing OP_CATCH whose tag - matches the one of the throw. The tag is taken from the - stack, while the output values are left in VALUES(). + The OP_THROW jumps to an enclosing OP_CATCH whose tag + matches the one of the throw. The tag is taken from the + stack, while the output values are left in VALUES(). */ static int c_throw(cl_env_ptr env, cl_object stmt, int flags) { - cl_object tag = pop(&stmt); - cl_object form = pop(&stmt); - if (stmt != ECL_NIL) - FEprogram_error_noreturn("THROW: Too many arguments.",0); - compile_form(env, tag, FLAG_PUSH); - compile_form(env, form, FLAG_VALUES); - asm_op(env, OP_THROW); - return flags; + cl_object tag = pop(&stmt); + cl_object form = pop(&stmt); + if (stmt != ECL_NIL) + FEprogram_error_noreturn("THROW: Too many arguments.",0); + compile_form(env, tag, FLAG_PUSH); + compile_form(env, form, FLAG_VALUES); + asm_op(env, OP_THROW); + return flags; } static int c_unwind_protect(cl_env_ptr env, cl_object args, int flags) { - cl_index label = asm_jmp(env, OP_PROTECT); + cl_index label = asm_jmp(env, OP_PROTECT); - flags = maybe_values(flags); + flags = maybe_values(flags); - /* Compile form to be protected */ - flags = compile_form(env, pop(&args), flags); - asm_op(env, OP_PROTECT_NORMAL); + /* Compile form to be protected */ + flags = compile_form(env, pop(&args), flags); + asm_op(env, OP_PROTECT_NORMAL); - /* Compile exit clause */ - asm_complete(env, OP_PROTECT, label); - compile_body(env, args, FLAG_IGNORE); - asm_op(env, OP_PROTECT_EXIT); + /* Compile exit clause */ + asm_complete(env, OP_PROTECT, label); + compile_body(env, args, FLAG_IGNORE); + asm_op(env, OP_PROTECT_EXIT); - return flags; + return flags; } /* - The OP_VALUES moves N values from the stack to VALUES(). + The OP_VALUES moves N values from the stack to VALUES(). - [OP_VALUES + n] + [OP_VALUES + n] */ static int c_values(cl_env_ptr env, cl_object args, int flags) { - if (!(flags & FLAG_USEFUL)) { - /* This value will be discarded. We do not care to - push it or to save it in VALUES */ - if (Null(args)) - return flags; - return compile_body(env, args, flags); - } else if (flags & FLAG_PUSH) { - /* We only need the first value. However, the rest - of arguments HAVE to be be evaluated */ - if (Null(args)) - return compile_form(env, ECL_NIL, flags); - flags = compile_form(env, pop(&args), FLAG_PUSH); - compile_body(env, args, FLAG_IGNORE); - return flags; - } else if (Null(args)) { - asm_op(env, OP_NOP); - } else { - int n = 0; - while (!Null(args)) { - compile_form(env, pop_maybe_nil(&args), FLAG_PUSH); - n++; - } - asm_op2(env, OP_VALUES, n); - } - return FLAG_VALUES; + if (!(flags & FLAG_USEFUL)) { + /* This value will be discarded. We do not care to + push it or to save it in VALUES */ + if (Null(args)) + return flags; + return compile_body(env, args, flags); + } else if (flags & FLAG_PUSH) { + /* We only need the first value. However, the rest + of arguments HAVE to be be evaluated */ + if (Null(args)) + return compile_form(env, ECL_NIL, flags); + flags = compile_form(env, pop(&args), FLAG_PUSH); + compile_body(env, args, FLAG_IGNORE); + return flags; + } else if (Null(args)) { + asm_op(env, OP_NOP); + } else { + int n = 0; + while (!Null(args)) { + compile_form(env, pop_maybe_nil(&args), FLAG_PUSH); + n++; + } + asm_op2(env, OP_VALUES, n); + } + return FLAG_VALUES; } static int @@ -2253,18 +2253,18 @@ compile_symbol(cl_env_ptr env, cl_object stmt, int flags) static int compile_form(cl_env_ptr env, cl_object stmt, int flags) { const cl_compiler_ptr c_env = env->c_env; - cl_object function; - int new_flags; + cl_object function; + int new_flags; - ecl_bds_bind(env, @'si::*current-form*', stmt); + ecl_bds_bind(env, @'si::*current-form*', stmt); BEGIN: - if (c_env->code_walker != OBJNULL) { - stmt = funcall(3, c_env->code_walker, stmt, - CONS(c_env->variables, c_env->macros)); - } - /* - * First try with variable references and quoted constants - */ + if (c_env->code_walker != OBJNULL) { + stmt = funcall(3, c_env->code_walker, stmt, + CONS(c_env->variables, c_env->macros)); + } + /* + * First try with variable references and quoted constants + */ if (Null(stmt)) { new_flags = compile_constant(env, stmt, flags); goto OUTPUT; @@ -2276,26 +2276,26 @@ compile_form(cl_env_ptr env, cl_object stmt, int flags) { new_flags = compile_constant(env, stmt, flags); } goto OUTPUT; - } - /* - * Next try with special forms. - */ - function = ECL_CONS_CAR(stmt); - if (ECL_SYMBOLP(function)) { - cl_object index = ecl_gethash(function, cl_core.compiler_dispatch); - if (index != OBJNULL) { - compiler_record *l = database + ecl_fixnum(index); - c_env->lexical_level += l->lexical_increment; - if (c_env->stepping && function != @'function' && - c_env->lexical_level) - asm_op2c(env, OP_STEPIN, stmt); - new_flags = (*(l->compiler))(env, ECL_CONS_CDR(stmt), flags); - if (c_env->stepping && function != @'function' && - c_env->lexical_level) - asm_op(env, OP_STEPOUT); - c_env->lexical_level -= l->lexical_increment; - goto OUTPUT; - } + } + /* + * Next try with special forms. + */ + function = ECL_CONS_CAR(stmt); + if (ECL_SYMBOLP(function)) { + cl_object index = ecl_gethash(function, cl_core.compiler_dispatch); + if (index != OBJNULL) { + compiler_record *l = database + ecl_fixnum(index); + c_env->lexical_level += l->lexical_increment; + if (c_env->stepping && function != @'function' && + c_env->lexical_level) + asm_op2c(env, OP_STEPIN, stmt); + new_flags = (*(l->compiler))(env, ECL_CONS_CDR(stmt), flags); + if (c_env->stepping && function != @'function' && + c_env->lexical_level) + asm_op(env, OP_STEPOUT); + c_env->lexical_level -= l->lexical_increment; + goto OUTPUT; + } /* * Next try to macroexpand */ @@ -2307,41 +2307,41 @@ compile_form(cl_env_ptr env, cl_object stmt, int flags) { } } } - /* - * Finally resort to ordinary function calls. - */ - if (c_env->stepping) - asm_op2c(env, OP_STEPIN, stmt); + /* + * Finally resort to ordinary function calls. + */ + if (c_env->stepping) + asm_op2c(env, OP_STEPIN, stmt); c_env->lexical_level++; - new_flags = c_call(env, stmt, flags); + new_flags = c_call(env, stmt, flags); c_env->lexical_level--; OUTPUT: - /* - flags new_flags action - PUSH PUSH --- - PUSH VALUES OP_PUSH - PUSH REG0 OP_PUSH - VALUES PUSH Impossible - VALUES VALUES --- - VALUES REG0 OP_VALUEREG0 - REG0 PUSH Impossible - REG0 VALUES --- - REG0 REG0 --- - */ - if (flags & FLAG_PUSH) { - if (new_flags & (FLAG_REG0 | FLAG_VALUES)) - asm_op(env, OP_PUSH); - } else if (flags & FLAG_VALUES) { - if (new_flags & FLAG_REG0) { - asm_op(env, OP_VALUEREG0); - } else if (new_flags & FLAG_PUSH) { - FEerror("Internal error in bytecodes compiler", 0); - } - } else if (new_flags & FLAG_PUSH) { - FEerror("Internal error in bytecodes compiler", 0); - } - ecl_bds_unwind1(env); - return flags; + /* + flags new_flags action + PUSH PUSH --- + PUSH VALUES OP_PUSH + PUSH REG0 OP_PUSH + VALUES PUSH Impossible + VALUES VALUES --- + VALUES REG0 OP_VALUEREG0 + REG0 PUSH Impossible + REG0 VALUES --- + REG0 REG0 --- + */ + if (flags & FLAG_PUSH) { + if (new_flags & (FLAG_REG0 | FLAG_VALUES)) + asm_op(env, OP_PUSH); + } else if (flags & FLAG_VALUES) { + if (new_flags & FLAG_REG0) { + asm_op(env, OP_VALUEREG0); + } else if (new_flags & FLAG_PUSH) { + FEerror("Internal error in bytecodes compiler", 0); + } + } else if (new_flags & FLAG_PUSH) { + FEerror("Internal error in bytecodes compiler", 0); + } + ecl_bds_unwind1(env); + return flags; } static void @@ -2358,10 +2358,10 @@ eval_nontrivial_form(cl_env_ptr env, cl_object form) { env->nvalues = 0; env->values[0] = ECL_NIL; new_c_env.constants = si_make_vector(ECL_T, ecl_make_fixnum(16), - ECL_T, /* Adjustable */ - ecl_make_fixnum(0), /* Fillp */ - ECL_NIL, /* displacement */ - ECL_NIL); + ECL_T, /* Adjustable */ + ecl_make_fixnum(0), /* Fillp */ + ECL_NIL, /* displacement */ + ECL_NIL); new_c_env.load_time_forms = ECL_NIL; new_c_env.env_depth = 0; new_c_env.env_size = 0; @@ -2450,8 +2450,8 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) if (c_env->load_time_forms != ECL_NIL) { cl_index *bytecodes = save_bytecodes(env, handle, current_pc(env)); cl_object p, forms_list = c_env->load_time_forms; - c_env->load_time_forms = ECL_NIL; - p = forms_list; + c_env->load_time_forms = ECL_NIL; + p = forms_list; do { cl_object r = ECL_CONS_CAR(p); cl_object constant = pop(&r); @@ -2461,16 +2461,16 @@ compile_with_load_time_forms(cl_env_ptr env, cl_object form, int flags) compile_with_load_time_forms(env, make_form, FLAG_REG0); asm_op2(env, OP_CSET, loc); compile_with_load_time_forms(env, init_form, FLAG_IGNORE); - ECL_RPLACA(p, ecl_make_fixnum(loc)); + ECL_RPLACA(p, ecl_make_fixnum(loc)); + p = ECL_CONS_CDR(p); + } while (p != ECL_NIL); + p = forms_list; + do { + cl_index loc = ecl_fixnum(ECL_CONS_CAR(p)); + /* Clear created constants (they cannot be printed) */ + c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0); p = ECL_CONS_CDR(p); } while (p != ECL_NIL); - p = forms_list; - do { - cl_index loc = ecl_fixnum(ECL_CONS_CAR(p)); - /* Clear created constants (they cannot be printed) */ - c_env->constants->vector.self.t[loc] = ecl_make_fixnum(0); - p = ECL_CONS_CDR(p); - } while (p != ECL_NIL); restore_bytecodes(env, bytecodes); } return output_flags; @@ -2523,78 +2523,78 @@ compile_body(cl_env_ptr env, cl_object body, int flags) static int c_cons(cl_env_ptr env, cl_object args, int flags) { - if (ecl_length(args) != 2) { - FEprogram_error_noreturn("CONS: Wrong number of arguments", 0); - } - compile_form(env, cl_first(args), FLAG_PUSH); - compile_form(env, cl_second(args), FLAG_REG0); - asm_op(env, OP_CONS); - return FLAG_REG0; + if (ecl_length(args) != 2) { + FEprogram_error_noreturn("CONS: Wrong number of arguments", 0); + } + compile_form(env, cl_first(args), FLAG_PUSH); + compile_form(env, cl_second(args), FLAG_REG0); + asm_op(env, OP_CONS); + return FLAG_REG0; } static int c_endp(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("ENDP: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_ENDP); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("ENDP: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_ENDP); + return FLAG_REG0; } static int c_car(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("CAR: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_CAR); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("CAR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CAR); + return FLAG_REG0; } static int c_cdr(cl_env_ptr env, cl_object args, int flags) { - cl_object list = pop(&args); - if (args != ECL_NIL) { - FEprogram_error_noreturn("CDR: Too many arguments", 0); - } - compile_form(env, list, FLAG_REG0); - asm_op(env, OP_CDR); - return FLAG_REG0; + cl_object list = pop(&args); + if (args != ECL_NIL) { + FEprogram_error_noreturn("CDR: Too many arguments", 0); + } + compile_form(env, list, FLAG_REG0); + asm_op(env, OP_CDR); + return FLAG_REG0; } static int c_list_listA(cl_env_ptr env, cl_object args, int flags, int op) { - cl_index n = ecl_length(args); - if (n == 0) { - return compile_form(env, ECL_NIL, flags); - } else { - while (ECL_CONS_CDR(args) != ECL_NIL) { - compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); - args = ECL_CONS_CDR(args); - } - compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); - asm_op2(env, op, n); - return FLAG_REG0; - } + cl_index n = ecl_length(args); + if (n == 0) { + return compile_form(env, ECL_NIL, flags); + } else { + while (ECL_CONS_CDR(args) != ECL_NIL) { + compile_form(env, ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + } + compile_form(env, ECL_CONS_CAR(args), FLAG_REG0); + asm_op2(env, op, n); + return FLAG_REG0; + } } static int c_list(cl_env_ptr env, cl_object args, int flags) { - return c_list_listA(env, args, flags, OP_LIST); + return c_list_listA(env, args, flags, OP_LIST); } static int c_listA(cl_env_ptr env, cl_object args, int flags) { - return c_list_listA(env, args, flags, OP_LISTA); + return c_list_listA(env, args, flags, OP_LISTA); } @@ -2602,23 +2602,23 @@ c_listA(cl_env_ptr env, cl_object args, int flags) /* ------------------------------------------------------------ LAMBDA OBJECTS: An interpreted function is a vector made of - the following components + the following components #(LAMBDA - {block-name | NIL} - {variable-env | NIL} - {function-env | NIL} - {block-env | NIL} - (list of variables declared special) - Nreq {var}* ; required arguments - Nopt {var value flag}* ; optional arguments - {rest-var NIL} ; rest variable - {T | NIL} ; allow other keys? - Nkey {key var value flag}* ; keyword arguments - Naux {var init} ; auxiliary variables - documentation-string - list-of-declarations - {form}* ; body) + {block-name | NIL} + {variable-env | NIL} + {function-env | NIL} + {block-env | NIL} + (list of variables declared special) + Nreq {var}* ; required arguments + Nopt {var value flag}* ; optional arguments + {rest-var NIL} ; rest variable + {T | NIL} ; allow other keys? + Nkey {key var value flag}* ; keyword arguments + Naux {var init} ; auxiliary variables + documentation-string + list-of-declarations + {form}* ; body) ------------------------------------------------------------ */ @@ -2626,9 +2626,9 @@ c_listA(cl_env_ptr env, cl_object args, int flags) Handles special declarations, removes declarations from body */ @(defun si::process-declarations (body &optional doc) - cl_object documentation = ECL_NIL, declarations = ECL_NIL, specials = ECL_NIL; + cl_object documentation = ECL_NIL, declarations = ECL_NIL, specials = ECL_NIL; @ - for (; !Null(body); body = ECL_CONS_CDR(body)) { + for (; !Null(body); body = ECL_CONS_CDR(body)) { cl_object form; unlikely_if (!ECL_LISTP(body)) FEill_formed_input(); @@ -2653,37 +2653,37 @@ c_listA(cl_env_ptr env, cl_object args, int flags) } } } - } - @(return cl_nreverse(declarations) body documentation specials) + } + @(return cl_nreverse(declarations) body documentation specials) @) cl_object si_process_lambda(cl_object lambda) { - cl_object documentation, declarations, specials; - cl_object lambda_list, body; + cl_object documentation, declarations, specials; + cl_object lambda_list, body; const cl_env_ptr env = ecl_process_env(); - unlikely_if (ECL_ATOM(lambda)) - FEprogram_error_noreturn("LAMBDA: No lambda list.", 0); + unlikely_if (ECL_ATOM(lambda)) + FEprogram_error_noreturn("LAMBDA: No lambda list.", 0); - lambda_list = ECL_CONS_CAR(lambda); + lambda_list = ECL_CONS_CAR(lambda); body = ECL_CONS_CDR(lambda); - declarations = @si::process-declarations(2, body, ECL_T); - body = env->values[1]; - documentation = env->values[2]; - specials = env->values[3]; + declarations = @si::process-declarations(2, body, ECL_T); + body = env->values[1]; + documentation = env->values[2]; + specials = env->values[3]; lambda_list = si_process_lambda_list(lambda_list, @'function'); { cl_index n = env->nvalues; - env->values[0] = lambda_list; - env->values[n++] = documentation; - env->values[n++] = specials; - env->values[n++] = declarations; - env->values[n++] = body; + env->values[0] = lambda_list; + env->values[n++] = documentation; + env->values[n++] = specials; + env->values[n++] = declarations; + env->values[n++] = body; env->nvalues = n; } - return lambda_list; + return lambda_list; } /* @@ -2693,13 +2693,13 @@ si_process_lambda(cl_object lambda) * FTYPE, FUNCTION, METHOD or DESTRUCTURING-BIND, and determines the * valid sytax. The output is made of several values: * - * VALUES(0) = (N req1 ... ) ; required values - * VALUES(1) = (N opt1 init1 flag1 ... ) ; optional values - * VALUES(2) = rest-var ; rest-variable, if any - * VALUES(3) = key-flag ; T if &key was supplied - * VALUES(4) = (N key1 var1 init1 flag1 ... ) ; keyword arguments - * VALUES(5) = allow-other-keys ; flag &allow-other-keys - * VALUES(6) = (N aux1 init1 ... ) ; auxiliary variables + * VALUES(0) = (N req1 ... ) ; required values + * VALUES(1) = (N opt1 init1 flag1 ... ) ; optional values + * VALUES(2) = rest-var ; rest-variable, if any + * VALUES(3) = key-flag ; T if &key was supplied + * VALUES(4) = (N key1 var1 init1 flag1 ... ) ; keyword arguments + * VALUES(5) = allow-other-keys ; flag &allow-other-keys + * VALUES(6) = (N aux1 init1 ... ) ; auxiliary variables * * 1°) The prefix "N" is an integer value denoting the number of * variables which are declared within this section of the lambda @@ -2718,15 +2718,15 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context) { #define push(v,l) { cl_object c = *l = CONS(v, *l); l = &ECL_CONS_CDR(c); } #define assert_var_name(v) \ - if (context == @'function') { \ - unlikely_if (ecl_symbol_type(v) & ecl_stp_constant) \ - FEillegal_variable_name(v); } + if (context == @'function') { \ + unlikely_if (ecl_symbol_type(v) & ecl_stp_constant) \ + FEillegal_variable_name(v); } cl_object lists[4] = {ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL}; cl_object *reqs = lists, *opts = lists+1, *keys = lists+2, *auxs = lists+3; - cl_object v, rest = ECL_NIL, lambda_list = org_lambda_list; - int nreq = 0, nopt = 0, nkey = 0, naux = 0; - cl_object allow_other_keys = ECL_NIL; - cl_object key_flag = ECL_NIL; + cl_object v, rest = ECL_NIL, lambda_list = org_lambda_list; + int nreq = 0, nopt = 0, nkey = 0, naux = 0; + cl_object allow_other_keys = ECL_NIL; + cl_object key_flag = ECL_NIL; enum { AT_REQUIREDS, AT_OPTIONALS, AT_REST, @@ -2735,99 +2735,99 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context) AT_AUXS } stage = AT_REQUIREDS; - if (!ECL_LISTP(lambda_list)) - goto ILLEGAL_LAMBDA; + if (!ECL_LISTP(lambda_list)) + goto ILLEGAL_LAMBDA; LOOP: if (Null(lambda_list)) goto OUTPUT; - if (!ECL_LISTP(lambda_list)) { - unlikely_if (context == @'function' || context == @'ftype') - goto ILLEGAL_LAMBDA; + if (!ECL_LISTP(lambda_list)) { + unlikely_if (context == @'function' || context == @'ftype') + goto ILLEGAL_LAMBDA; v = lambda_list; lambda_list = ECL_NIL; goto REST; - } - v = ECL_CONS_CAR(lambda_list); - lambda_list = ECL_CONS_CDR(lambda_list); - if (v == @'&optional') { - unlikely_if (stage >= AT_OPTIONALS) - goto ILLEGAL_LAMBDA; - stage = AT_OPTIONALS; - goto LOOP; - } - if (v == @'&rest' || (v == @'&body' && (context == @'si::macro' || context == @'destructuring-bind'))) { - unlikely_if (ECL_ATOM(lambda_list)) + } + v = ECL_CONS_CAR(lambda_list); + lambda_list = ECL_CONS_CDR(lambda_list); + if (v == @'&optional') { + unlikely_if (stage >= AT_OPTIONALS) goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(lambda_list); - lambda_list = ECL_CONS_CDR(lambda_list); -REST: unlikely_if (stage >= AT_REST) - goto ILLEGAL_LAMBDA; - stage = AT_REST; - rest = v; - goto LOOP; - } - if (v == @'&key') { - unlikely_if (stage >= AT_KEYS) - goto ILLEGAL_LAMBDA; - key_flag = ECL_T; - stage = AT_KEYS; - goto LOOP; - } - if (v == @'&aux') { - unlikely_if (stage >= AT_AUXS) - goto ILLEGAL_LAMBDA; - stage = AT_AUXS; - goto LOOP; - } - if (v == @'&allow-other-keys') { - allow_other_keys = ECL_T; - unlikely_if (stage != AT_KEYS) - goto ILLEGAL_LAMBDA; - stage = AT_OTHER_KEYS; - goto LOOP; - } - switch (stage) { - case AT_REQUIREDS: - nreq++; + stage = AT_OPTIONALS; + goto LOOP; + } + if (v == @'&rest' || (v == @'&body' && (context == @'si::macro' || context == @'destructuring-bind'))) { + unlikely_if (ECL_ATOM(lambda_list)) + goto ILLEGAL_LAMBDA; + v = ECL_CONS_CAR(lambda_list); + lambda_list = ECL_CONS_CDR(lambda_list); +REST: unlikely_if (stage >= AT_REST) + goto ILLEGAL_LAMBDA; + stage = AT_REST; + rest = v; + goto LOOP; + } + if (v == @'&key') { + unlikely_if (stage >= AT_KEYS) + goto ILLEGAL_LAMBDA; + key_flag = ECL_T; + stage = AT_KEYS; + goto LOOP; + } + if (v == @'&aux') { + unlikely_if (stage >= AT_AUXS) + goto ILLEGAL_LAMBDA; + stage = AT_AUXS; + goto LOOP; + } + if (v == @'&allow-other-keys') { + allow_other_keys = ECL_T; + unlikely_if (stage != AT_KEYS) + goto ILLEGAL_LAMBDA; + stage = AT_OTHER_KEYS; + goto LOOP; + } + switch (stage) { + case AT_REQUIREDS: + nreq++; assert_var_name(v); - push(v, reqs); - break; - case AT_OPTIONALS: { - cl_object spp = ECL_NIL; - cl_object init = ECL_NIL; - if (!ECL_ATOM(v) && (context != @'ftype')) { - cl_object x = v; + push(v, reqs); + break; + case AT_OPTIONALS: { + cl_object spp = ECL_NIL; + cl_object init = ECL_NIL; + if (!ECL_ATOM(v) && (context != @'ftype')) { + cl_object x = v; unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(x); + v = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); - if (!Null(x)) { + if (!Null(x)) { unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - init = ECL_CONS_CAR(x); + init = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); - if (!Null(x)) { + if (!Null(x)) { unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - spp = ECL_CONS_CAR(x); + spp = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); if (spp != ECL_NIL) assert_var_name(spp); - unlikely_if (!Null(x)) - goto ILLEGAL_LAMBDA; - } - } - } - nopt++; + unlikely_if (!Null(x)) + goto ILLEGAL_LAMBDA; + } + } + } + nopt++; assert_var_name(v); - push(v, opts); - push(init, opts); + push(v, opts); + push(init, opts); push(spp, opts); - break; + break; } - case AT_REST: - /* If we get here, the user has declared more than one - * &rest variable, as in (lambda (&rest x y) ...) */ - goto ILLEGAL_LAMBDA; - case AT_KEYS: { - cl_object init = ECL_NIL; - cl_object spp = ECL_NIL; + case AT_REST: + /* If we get here, the user has declared more than one + * &rest variable, as in (lambda (&rest x y) ...) */ + goto ILLEGAL_LAMBDA; + case AT_KEYS: { + cl_object init = ECL_NIL; + cl_object spp = ECL_NIL; cl_object key; if (context == @'ftype') { unlikely_if (ECL_ATOM(v)) @@ -2836,79 +2836,79 @@ REST: unlikely_if (stage >= AT_REST) v = CADR(v); goto KEY_PUSH; } - if (!ECL_ATOM(v)) { - cl_object x = v; - v = ECL_CONS_CAR(x); + if (!ECL_ATOM(v)) { + cl_object x = v; + v = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); - if (!Null(x)) { + if (!Null(x)) { unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - init = ECL_CONS_CAR(x); + init = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); - if (!Null(x)) { + if (!Null(x)) { unlikely_if (!ECL_LISTP(x)) goto ILLEGAL_LAMBDA; - spp = ECL_CONS_CAR(x); + spp = ECL_CONS_CAR(x); x = ECL_CONS_CDR(x); - unlikely_if (!Null(x)) - goto ILLEGAL_LAMBDA; + unlikely_if (!Null(x)) + goto ILLEGAL_LAMBDA; if (spp != ECL_NIL) assert_var_name(spp); - } - } - } - if (CONSP(v)) { - key = ECL_CONS_CAR(v); + } + } + } + if (CONSP(v)) { + key = ECL_CONS_CAR(v); v = ECL_CONS_CDR(v); - unlikely_if (ECL_ATOM(v) || !Null(ECL_CONS_CDR(v))) - goto ILLEGAL_LAMBDA; - v = ECL_CONS_CAR(v); - if (context == @'function') - assert_type_symbol(v); - assert_type_symbol(key); - } else { - int intern_flag; - key = ecl_intern(ecl_symbol_name(v), cl_core.keyword_package, - &intern_flag); - } + unlikely_if (ECL_ATOM(v) || !Null(ECL_CONS_CDR(v))) + goto ILLEGAL_LAMBDA; + v = ECL_CONS_CAR(v); + if (context == @'function') + assert_type_symbol(v); + assert_type_symbol(key); + } else { + int intern_flag; + key = ecl_intern(ecl_symbol_name(v), cl_core.keyword_package, + &intern_flag); + } KEY_PUSH: - nkey++; - push(key, keys); + nkey++; + push(key, keys); assert_var_name(v); - push(v, keys); - push(init, keys); + push(v, keys); + push(init, keys); push(spp, keys); - break; + break; } - default: { + default: { cl_object init; - if (ECL_ATOM(v)) { - init = ECL_NIL; - } else if (Null(CDDR(v))) { - cl_object x = v; - v = ECL_CONS_CAR(x); - init = CADR(x); - } else - goto ILLEGAL_LAMBDA; - naux++; + if (ECL_ATOM(v)) { + init = ECL_NIL; + } else if (Null(CDDR(v))) { + cl_object x = v; + v = ECL_CONS_CAR(x); + init = CADR(x); + } else + goto ILLEGAL_LAMBDA; + naux++; assert_var_name(v); - push(v, auxs); - push(init, auxs); + push(v, auxs); + push(init, auxs); } - } - goto LOOP; + } + goto LOOP; OUTPUT: - if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT) - FEprogram_error_noreturn("LAMBDA: Argument list ist too long, ~S.", 1, - org_lambda_list); - @(return CONS(ecl_make_fixnum(nreq), lists[0]) - CONS(ecl_make_fixnum(nopt), lists[1]) - rest - key_flag - CONS(ecl_make_fixnum(nkey), lists[2]) - allow_other_keys - lists[3]) + if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT) + FEprogram_error_noreturn("LAMBDA: Argument list ist too long, ~S.", 1, + org_lambda_list); + @(return CONS(ecl_make_fixnum(nreq), lists[0]) + CONS(ecl_make_fixnum(nopt), lists[1]) + rest + key_flag + CONS(ecl_make_fixnum(nkey), lists[2]) + allow_other_keys + lists[3]) ILLEGAL_LAMBDA: - FEprogram_error_noreturn("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list); + FEprogram_error_noreturn("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list); #undef push #undef assert_var_name @@ -2933,59 +2933,59 @@ c_default(cl_env_ptr env, cl_object var, cl_object stmt, cl_object flag, cl_obje cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { - cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; - cl_object specials, doc, decl, body, output; - cl_index handle; - struct cl_compiler_env *old_c_env, new_c_env; + cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; + cl_object specials, doc, decl, body, output; + cl_index handle; + struct cl_compiler_env *old_c_env, new_c_env; - ecl_bds_bind(env, @'si::*current-form*', - @list*(3, @'ext::lambda-block', name, lambda)); + ecl_bds_bind(env, @'si::*current-form*', + @list*(3, @'ext::lambda-block', name, lambda)); - old_c_env = env->c_env; - c_new_env(env, &new_c_env, ECL_NIL, old_c_env); - new_c_env.lexical_level++; + old_c_env = env->c_env; + c_new_env(env, &new_c_env, ECL_NIL, old_c_env); + new_c_env.lexical_level++; - reqs = si_process_lambda(lambda); - opts = env->values[1]; - rest = env->values[2]; - key = env->values[3]; - keys = env->values[4]; - allow_other_keys = env->values[5]; - auxs = env->values[6]; - doc = env->values[7]; - specials = env->values[8]; - decl = env->values[9]; - body = env->values[10]; + reqs = si_process_lambda(lambda); + opts = env->values[1]; + rest = env->values[2]; + key = env->values[3]; + keys = env->values[4]; + allow_other_keys = env->values[5]; + auxs = env->values[6]; + doc = env->values[7]; + specials = env->values[8]; + decl = env->values[9]; + body = env->values[10]; - handle = asm_begin(env); + handle = asm_begin(env); - /* Transform (SETF fname) => fname */ - if (!Null(name) && Null(si_valid_function_name_p(name))) - FEprogram_error_noreturn("LAMBDA: Not a valid function name ~S",1,name); + /* Transform (SETF fname) => fname */ + if (!Null(name) && Null(si_valid_function_name_p(name))) + FEprogram_error_noreturn("LAMBDA: Not a valid function name ~S",1,name); - /* We register as special variable a symbol which is not - * to be used. We use this to mark the boundary of a function - * environment and when code-walking */ - c_register_var(env, @'si::function-boundary', TRUE, FALSE); + /* We register as special variable a symbol which is not + * to be used. We use this to mark the boundary of a function + * environment and when code-walking */ + c_register_var(env, @'si::function-boundary', TRUE, FALSE); - reqs = ECL_CONS_CDR(reqs); /* Required arguments */ - while (!Null(reqs)) { - cl_object var = pop(&reqs); + reqs = ECL_CONS_CDR(reqs); /* Required arguments */ + while (!Null(reqs)) { + cl_object var = pop(&reqs); asm_op(env, OP_POPREQ); c_bind(env, var, specials); - } + } opts = ECL_CONS_CDR(opts); - while (!Null(opts)) { /* Optional arguments */ + while (!Null(opts)) { /* Optional arguments */ cl_object var = pop(&opts); cl_object stmt = pop(&opts); cl_object flag = pop(&opts); asm_op(env, OP_POPOPT); c_default(env, var, stmt, flag, specials); } - if (Null(rest) && Null(key)) { /* Check no excess arguments */ + if (Null(rest) && Null(key)) { /* Check no excess arguments */ asm_op(env, OP_NOMORE); } - if (!Null(rest)) { /* &rest argument */ + if (!Null(rest)) { /* &rest argument */ asm_op(env, OP_POPREST); c_bind(env, rest, specials); } @@ -3006,54 +3006,54 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) { ECL_RPLACD(aux, names); } - while (!Null(auxs)) { /* Local bindings */ - cl_object var = pop(&auxs); - cl_object value = pop(&auxs); - compile_form(env, value, FLAG_REG0); - c_bind(env, var, specials); - } - c_declare_specials(env, specials); + while (!Null(auxs)) { /* Local bindings */ + cl_object var = pop(&auxs); + cl_object value = pop(&auxs); + compile_form(env, value, FLAG_REG0); + c_bind(env, var, specials); + } + c_declare_specials(env, specials); - if (!Null(name)) { - compile_form(env, @list*(3, @'block', si_function_block_name(name), + if (!Null(name)) { + compile_form(env, @list*(3, @'block', si_function_block_name(name), body), FLAG_VALUES); - } else { - while (!Null(decl)) { - cl_object l = ECL_CONS_CAR(decl); - if (ECL_CONSP(l) && ECL_CONS_CAR(l) == @'si::function-block-name') { - name = ECL_CONS_CAR(ECL_CONS_CDR(l)); - break; - } - decl = ECL_CONS_CDR(decl); - } - compile_body(env, body, FLAG_VALUES); - } + } else { + while (!Null(decl)) { + cl_object l = ECL_CONS_CAR(decl); + if (ECL_CONSP(l) && ECL_CONS_CAR(l) == @'si::function-block-name') { + name = ECL_CONS_CAR(ECL_CONS_CDR(l)); + break; + } + decl = ECL_CONS_CDR(decl); + } + compile_body(env, body, FLAG_VALUES); + } /* Only undo special bindings */ - c_undo_bindings(env, old_c_env->variables, 1); - asm_op(env, OP_EXIT); + c_undo_bindings(env, old_c_env->variables, 1); + asm_op(env, OP_EXIT); if (Null(ecl_symbol_value(@'si::*keep-definitions*'))) lambda = ECL_NIL; - output = asm_end(env, handle, lambda); - output->bytecodes.name = name; + output = asm_end(env, handle, lambda); + output->bytecodes.name = name; - old_c_env->load_time_forms = env->c_env->load_time_forms; - env->c_env = old_c_env; + old_c_env->load_time_forms = env->c_env->load_time_forms; + env->c_env = old_c_env; - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); - return output; + return output; } static cl_object ecl_function_block_name(cl_object name) { - if (ECL_SYMBOLP(name)) { - return name; - } else if (CONSP(name) && ECL_CONS_CAR(name) == @'setf') { - name = ECL_CONS_CDR(name); - if (CONSP(name)) { + if (ECL_SYMBOLP(name)) { + return name; + } else if (CONSP(name) && ECL_CONS_CAR(name) == @'setf') { + name = ECL_CONS_CDR(name); + if (CONSP(name)) { cl_object output = ECL_CONS_CAR(name); if (ECL_SYMBOLP(output) && Null(ECL_CONS_CDR(name))) return output; @@ -3081,42 +3081,42 @@ si_valid_function_name_p(cl_object name) cl_object si_make_lambda(cl_object name, cl_object rest) { - cl_object lambda; + cl_object lambda; const cl_env_ptr the_env = ecl_process_env(); - volatile cl_compiler_env_ptr old_c_env = the_env->c_env; - struct cl_compiler_env new_c_env; + volatile cl_compiler_env_ptr old_c_env = the_env->c_env; + struct cl_compiler_env new_c_env; - c_new_env(the_env, &new_c_env, ECL_NIL, 0); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - lambda = ecl_make_lambda(the_env, name, rest); - } ECL_UNWIND_PROTECT_EXIT { - the_env->c_env = old_c_env; - } ECL_UNWIND_PROTECT_END; - @(return lambda) + c_new_env(the_env, &new_c_env, ECL_NIL, 0); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + lambda = ecl_make_lambda(the_env, name, rest); + } ECL_UNWIND_PROTECT_EXIT { + the_env->c_env = old_c_env; + } ECL_UNWIND_PROTECT_END; + @(return lambda) } @(defun si::eval-with-env (form &optional (env ECL_NIL) (stepping ECL_NIL) (compiler_env_p ECL_NIL) (execute ECL_T)) - volatile cl_compiler_env_ptr old_c_env; - struct cl_compiler_env new_c_env; - cl_object interpreter_env, compiler_env; + volatile cl_compiler_env_ptr old_c_env; + struct cl_compiler_env new_c_env; + cl_object interpreter_env, compiler_env; @ - /* - * Compile to bytecodes. - */ - if (compiler_env_p == ECL_NIL) { - interpreter_env = env; - compiler_env = ECL_NIL; - } else { - interpreter_env = ECL_NIL; - compiler_env = env; - } - old_c_env = the_env->c_env; - c_new_env(the_env, &new_c_env, compiler_env, 0); - guess_environment(the_env, interpreter_env); - new_c_env.lex_env = env; - new_c_env.stepping = stepping != ECL_NIL; - ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* + * Compile to bytecodes. + */ + if (compiler_env_p == ECL_NIL) { + interpreter_env = env; + compiler_env = ECL_NIL; + } else { + interpreter_env = ECL_NIL; + compiler_env = env; + } + old_c_env = the_env->c_env; + c_new_env(the_env, &new_c_env, compiler_env, 0); + guess_environment(the_env, interpreter_env); + new_c_env.lex_env = env; + new_c_env.stepping = stepping != ECL_NIL; + ECL_UNWIND_PROTECT_BEGIN(the_env) { if (Null(execute)) { cl_index handle = asm_begin(the_env); new_c_env.mode = FLAG_LOAD; @@ -3128,24 +3128,24 @@ si_make_lambda(cl_object name, cl_object rest) } else { eval_form(the_env, form); } - } ECL_UNWIND_PROTECT_EXIT { - /* Clear up */ - the_env->c_env = old_c_env; - memset(&new_c_env, 0, sizeof(new_c_env)); - } ECL_UNWIND_PROTECT_END; - return the_env->values[0]; + } ECL_UNWIND_PROTECT_EXIT { + /* Clear up */ + the_env->c_env = old_c_env; + memset(&new_c_env, 0, sizeof(new_c_env)); + } ECL_UNWIND_PROTECT_END; + return the_env->values[0]; @) void init_compiler() { - cl_object dispatch_table = - cl_core.compiler_dispatch = - cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ + cl_object dispatch_table = + cl_core.compiler_dispatch = + cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ cl_core.rehash_size, cl_core.rehash_threshold); - int i; - for (i = 0; database[i].symbol; i++) { - ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); - } + int i; + for (i = 0; database[i].symbol; i++) { + ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); + } } diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 4680982d1..4bf020c06 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -24,119 +24,119 @@ static cl_opcode *base = NULL; static void print_noarg(const char *s) { - ecl_princ_str(s, ECL_NIL); + ecl_princ_str(s, ECL_NIL); } static void print_oparg(const char *s, cl_fixnum n) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); } static void print_arg(const char *s, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(x, ECL_NIL); } static void print_oparg_arg(const char *s, cl_fixnum n, cl_object x) { - ecl_princ_str(s, ECL_NIL); - ecl_princ(ecl_make_fixnum(n), ECL_NIL); - ecl_princ_str(",", ECL_NIL); - ecl_princ(x, ECL_NIL); + ecl_princ_str(s, ECL_NIL); + ecl_princ(ecl_make_fixnum(n), ECL_NIL); + ecl_princ_str(",", ECL_NIL); + ecl_princ(x, ECL_NIL); } #define GET_DATA(r,v,data) { \ - cl_oparg ndx; \ - GET_OPARG(ndx, v); \ - r = data[ndx]; \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data[ndx]; \ } static void disassemble_lambda(cl_object bytecodes) { - const cl_env_ptr env = ecl_process_env(); - cl_object *data; - cl_opcode *vector; + const cl_env_ptr env = ecl_process_env(); + cl_object *data; + cl_opcode *vector; - ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); + ecl_bds_bind(env, @'*print-pretty*', ECL_NIL); - /* Print required arguments */ - data = bytecodes->bytecodes.data->vector.self.t; - cl_print(1,bytecodes->bytecodes.data); + /* Print required arguments */ + data = bytecodes->bytecodes.data->vector.self.t; + cl_print(1,bytecodes->bytecodes.data); - /* Name of LAMBDA */ - print_arg("\nName:\t\t", bytecodes->bytecodes.name); - if (bytecodes->bytecodes.name == OBJNULL || - bytecodes->bytecodes.name == @'si::bytecodes') { - print_noarg("\nEvaluated form:"); - goto NO_ARGS; - } + /* Name of LAMBDA */ + print_arg("\nName:\t\t", bytecodes->bytecodes.name); + if (bytecodes->bytecodes.name == OBJNULL || + bytecodes->bytecodes.name == @'si::bytecodes') { + print_noarg("\nEvaluated form:"); + goto NO_ARGS; + } NO_ARGS: - base = vector = (cl_opcode *)bytecodes->bytecodes.code; - disassemble(bytecodes, vector); + base = vector = (cl_opcode *)bytecodes->bytecodes.code; + disassemble(bytecodes, vector); - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); } /* -------------------- DISASSEMBLER CORE -------------------- */ -/* OP_FLET nfun{arg}, fun1{object} +/* OP_FLET nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_flet(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("FLET"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tFLET\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("FLET"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tFLET\t", fun->bytecodes.name); + } + return vector; } -/* OP_LABELS nfun{arg}, fun1{object} +/* OP_LABELS nfun{arg}, fun1{object} ... - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". */ static cl_opcode * disassemble_labels(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - GET_OPARG(nfun, vector); - print_noarg("LABELS"); - while (nfun--) { - cl_object fun; - GET_DATA(fun, vector, data); - print_arg("\n\tLABELS\t", fun->bytecodes.name); - } - return vector; + cl_index nfun; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + GET_OPARG(nfun, vector); + print_noarg("LABELS"); + while (nfun--) { + cl_object fun; + GET_DATA(fun, vector, data); + print_arg("\n\tLABELS\t", fun->bytecodes.name); + } + return vector; } -/* OP_PROGV bindings{list} +/* OP_PROGV bindings{list} ... OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). */ static cl_opcode * disassemble_progv(cl_object bytecodes, cl_opcode *vector) { - print_noarg("PROGV"); - vector = disassemble(bytecodes, vector); - print_noarg("\t\t; progv"); - return vector; + print_noarg("PROGV"); + vector = disassemble(bytecodes, vector); + print_noarg("\t\t; progv"); + return vector; } -/* OP_TAGBODY n{arg} +/* OP_TAGBODY n{arg} label1 ... labeln @@ -146,493 +146,493 @@ labeln: ... OP_EXIT - High level construct for the TAGBODY form. + High level construct for the TAGBODY form. */ static cl_opcode * disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { - cl_index i, ntags; - cl_opcode *destination; - GET_OPARG(ntags, vector); - print_noarg("TAGBODY"); - for (i=0; ibytecodes.data->vector.self.t; - cl_object line_no; + const char *string; + cl_object o; + cl_fixnum n, m; + cl_object line_format; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + cl_object line_no; - if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) - line_format = make_constant_base_string("~%~4d\t"); - else - line_format = ECL_NIL; + if (cl_fboundp(@'si::formatter-aux') != ECL_NIL) + line_format = make_constant_base_string("~%~4d\t"); + else + line_format = ECL_NIL; BEGIN: - if (1) { - line_no = ecl_make_fixnum(vector-base); - } else { - line_no = @'*'; - } - if (line_format != ECL_NIL) { - cl_format(3, ECL_T, line_format, line_no); - } else { - ecl_princ_char('\n', ECL_NIL); - ecl_princ(line_no, ECL_NIL); - ecl_princ_char('\t', ECL_NIL); - } - switch (GET_OPCODE(vector)) { + if (1) { + line_no = ecl_make_fixnum(vector-base); + } else { + line_no = @'*'; + } + if (line_format != ECL_NIL) { + cl_format(3, ECL_T, line_format, line_no); + } else { + ecl_princ_char('\n', ECL_NIL); + ecl_princ(line_no, ECL_NIL); + ecl_princ_char('\t', ECL_NIL); + } + switch (GET_OPCODE(vector)) { - /* OP_NOP - Sets VALUES(0) = NIL and NVALUES = 1 - */ - case OP_NOP: string = "NOP"; goto NOARG; - - case OP_INT: string = "QUOTE\t"; - GET_OPARG(n, vector); - goto OPARG; - - case OP_PINT: string = "PUSH\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_QUOTE - Sets VALUES(0) to an immediate value. - */ - case OP_QUOTE: string = "QUOTE\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_CSET n{arg} - Replace constant with a computed value - */ - case OP_CSET: string = "CSET\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_VAR n{arg} - Sets NVALUES=1 and VALUES(0) to the value of the n-th local. - */ - case OP_VAR: string = "VAR\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_VARS var{symbol} - Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ - case OP_VARS: string = "VARS\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSH - Pushes the object in VALUES(0). - */ - case OP_PUSH: string = "PUSH\tVALUES(0)"; - goto NOARG; - - case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; - goto NOARG; - - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. - */ - case OP_PUSHV: string = "PUSHV\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ - case OP_PUSHVS: string = "PUSHVS\t"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. - */ - case OP_PUSHQ: string = "PUSH\t'"; - GET_DATA(o, vector, data); - goto ARG; - - /* OP_PUSHVALUES - Pushes the values output by the last form, plus the number - of values. - */ - case OP_PUSHVALUES: string = "PUSH\tVALUES"; - goto NOARG; - /* OP_PUSHMOREVALUES - Adds more values to the ones pushed by OP_PUSHVALUES. - */ - case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; - goto NOARG; - /* OP_POP - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP: string = "POP"; - goto NOARG; - /* OP_POP1 - Pops a single value pushed by a OP_PUSH[V[S]] operator. - */ - case OP_POP1: string = "POP1"; - goto NOARG; - /* OP_POPVALUES - Pops all values pushed by a OP_PUSHVALUES operator. - */ - case OP_POPVALUES: string = "POP\tVALUES"; - goto NOARG; - - case OP_BLOCK: string = "BLOCK\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CATCH: string = "CATCH\tREG0"; - goto NOARG; - case OP_DO: string = "BLOCK\t"; - o = ECL_NIL; - goto ARG; - case OP_FRAME: string = "FRAME\t"; - goto JMP; - - /* OP_CALL n{arg} - Calls the function in VALUES(0) with N arguments which - have been deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_CALL: string = "CALL\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The output values are left in VALUES. - */ - case OP_CALLG: string = "CALLG\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - - /* OP_FCALL n{arg} - Calls the function in the stack with N arguments which - have been also deposited in the stack. The output values - are left in VALUES(...) - */ - case OP_STEPCALL: - case OP_FCALL: string = "FCALL\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_MCALL - Similar to FCALL, but gets the number of arguments from - the stack (They all have been deposited by OP_PUSHVALUES) - */ - case OP_MCALL: string = "MCALL"; - goto NOARG; - - /* OP_POPREQ - Extracts next required argument. - */ - case OP_POPREQ: string = "POP\tREQ"; - goto NOARG; - /* OP_NOMORE - Ensure there are no more arguments. - */ - case OP_NOMORE: string = "NOMORE"; - goto NOARG; - /* OP_POPOPT - Extracts next optional argument. - */ - case OP_POPOPT: string = "POP\tOPT"; - goto NOARG; - /* OP_POPREST - Extracts list of remaining arguments. - */ - case OP_POPREST: string = "POP\tREST"; - goto NOARG; - /* OP_PUSHKEYS - Parses the keyword arguments + /* OP_NOP + Sets VALUES(0) = NIL and NVALUES = 1 */ - case OP_PUSHKEYS: string = "PUSH\tKEYS "; - GET_DATA(o, vector, data); - goto ARG; + case OP_NOP: string = "NOP"; goto NOARG; - /* OP_EXIT - Marks the end of a high level construct - */ - case OP_EXIT: print_noarg("EXIT"); - return vector; - /* OP_EXIT_FRAME - Marks the end of a high level construct (BLOCK, CATCH...) - */ - case OP_EXIT_FRAME: string = "EXIT\tFRAME"; - goto NOARG; - /* OP_EXIT_TAGBODY - Marks the end of a high level construct (TAGBODY) - */ - case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); - return vector; + case OP_INT: string = "QUOTE\t"; + GET_OPARG(n, vector); + goto OPARG; - case OP_FLET: vector = disassemble_flet(bytecodes, vector); - break; - case OP_LABELS: vector = disassemble_labels(bytecodes, vector); - break; + case OP_PINT: string = "PUSH\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_LFUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_LFUNCTION: string = "LOCFUNC\t"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_QUOTE + Sets VALUES(0) to an immediate value. + */ + case OP_QUOTE: string = "QUOTE\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_FUNCTION: string = "SYMFUNC\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_CSET n{arg} + Replace constant with a computed value + */ + case OP_CSET: string = "CSET\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_CLOSE name{arg} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - case OP_CLOSE: string = "CLOSE\t"; - GET_DATA(o, vector, data); - goto ARG; + /* OP_VAR n{arg} + Sets NVALUES=1 and VALUES(0) to the value of the n-th local. + */ + case OP_VAR: string = "VAR\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_GO n{arg}, tag-ndx{arg} - OP_QUOTE tag-name{symbol} - Jumps to the tag which is defined at the n-th position in - the lexical environment. TAG-NAME is kept for debugging - purposes. - */ - case OP_GO: string = "GO\t"; - GET_OPARG(n, vector); - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - goto OPARG_ARG; + /* OP_VARS var{symbol} + Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + case OP_VARS: string = "VARS\t"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. - */ - case OP_RETURN: string = "RETFROM"; - GET_OPARG(n, vector); - goto OPARG; + /* OP_PUSH + Pushes the object in VALUES(0). + */ + case OP_PUSH: string = "PUSH\tVALUES(0)"; + goto NOARG; - /* OP_THROW - Jumps to an enclosing CATCH form whose tag matches the one - of the THROW. The tag is taken from the stack, while the - output values are left in VALUES(...). - */ - case OP_THROW: string = "THROW"; - goto NOARG; + case OP_VALUEREG0: string = "SET\tVALUES(0),REG0"; + goto NOARG; - /* OP_JMP label{arg} - OP_JNIL label{arg} - OP_JT label{arg} - OP_JEQ label{arg}, value{object} - OP_JNEQ label{arg}, value{object} - Direct or conditional jumps. The conditional jumps are made - comparing with the value of VALUES(0). - */ - case OP_JMP: string = "JMP\t"; - goto JMP; - case OP_JNIL: string = "JNIL\t"; - goto JMP; - case OP_JT: string = "JT\t"; - JMP: { GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG; - } - case OP_JEQL: string = "JEQL\t"; - goto JEQL; - case OP_JNEQL: string = "JNEQL\t"; - JEQL: { GET_DATA(o, vector, data); - GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - goto OPARG_ARG; - } - case OP_NOT: string = "NOT"; - goto NOARG; + /* OP_PUSHV n{arg} + Pushes the value of the n-th local onto the stack. + */ + case OP_PUSHV: string = "PUSHV\t"; + GET_OPARG(n, vector); + goto OPARG; - /* OP_UNBIND n{arg} - Undo "n" bindings of lexical variables. - */ - case OP_UNBIND: string = "UNBIND\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_UNBINDS n{arg} - Undo "n" bindings of special variables. - */ - case OP_UNBINDS: string = "UNBINDS\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_BIND name{symbol} - OP_PBIND name{symbol} - OP_BINDS name{symbol} - OP_PBINDS name{symbol} - Binds a lexical or special variable to the either the - value of VALUES(0), to the first value of the stack, or - to the n-th value of VALUES(...). - */ - case OP_BIND: string = "BIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBIND: string = "PBIND\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBIND: string = "VBIND\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - case OP_BINDS: string = "BINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PBINDS: string = "PBINDS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VBINDS: string = "VBINDS\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in VALUES(0) (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). - */ - case OP_SETQ: string = "SETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_PSETQ: string = "PSETQ\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_VSETQ: string = "VSETQ\t"; - GET_OPARG(m, vector); - o = ecl_make_fixnum(m); - GET_OPARG(n, vector); - goto OPARG_ARG; - case OP_SETQS: string = "SETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_PSETQS: string = "PSETQS\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_VSETQS: string = "VSETQS\t"; - GET_DATA(o, vector, data); - GET_OPARG(n, vector); - goto OPARG_ARG; + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + case OP_PUSHVS: string = "PUSHVS\t"; + GET_DATA(o, vector, data); + goto ARG; - case OP_PROGV: vector = disassemble_progv(bytecodes, vector); - break; - case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); - return vector; + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + case OP_PUSHQ: string = "PUSH\t'"; + GET_DATA(o, vector, data); + goto ARG; - /* OP_VALUES n{arg} - Pop N values from the stack and store them in VALUES(...) - */ - case OP_VALUES: string = "VALUES\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_NTHVAL - Set VALUES(0) to the N-th value of the VALUES(...) list. - The index N-th is extracted from the top of the stack. - */ - case OP_NTHVAL: string = "NTHVAL\t"; - goto NOARG; - case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); - break; - case OP_PROTECT: string = "PROTECT\t"; - goto JMP; - case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; - goto NOARG; - case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; - goto NOARG; - case OP_NIL: string = "QUOTE\tNIL"; - goto NOARG; - case OP_PUSHNIL: string = "PUSH\t'NIL"; - goto NOARG; - case OP_STEPIN: string = "STEP\tIN,"; - GET_DATA(o, vector, data); - goto ARG; - case OP_STEPOUT: string = "STEP\tOUT"; - goto NOARG; + /* OP_PUSHVALUES + Pushes the values output by the last form, plus the number + of values. + */ + case OP_PUSHVALUES: string = "PUSH\tVALUES"; + goto NOARG; + /* OP_PUSHMOREVALUES + Adds more values to the ones pushed by OP_PUSHVALUES. + */ + case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES"; + goto NOARG; + /* OP_POP + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP: string = "POP"; + goto NOARG; + /* OP_POP1 + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP1: string = "POP1"; + goto NOARG; + /* OP_POPVALUES + Pops all values pushed by a OP_PUSHVALUES operator. + */ + case OP_POPVALUES: string = "POP\tVALUES"; + goto NOARG; - case OP_CONS: string = "CONS"; goto NOARG; - case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; - case OP_CAR: string = "CAR\tREG0"; goto NOARG; - case OP_CDR: string = "CDR\tREG0"; goto NOARG; - case OP_LIST: string = "LIST\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_LISTA: string = "LIST*\t"; - GET_OPARG(n, vector); - goto OPARG; - case OP_CALLG1: string = "CALLG1\t"; - GET_DATA(o, vector, data); - goto ARG; - case OP_CALLG2: string = "CALLG2\t"; - GET_DATA(o, vector, data); - goto ARG; + case OP_BLOCK: string = "BLOCK\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CATCH: string = "CATCH\tREG0"; + goto NOARG; + case OP_DO: string = "BLOCK\t"; + o = ECL_NIL; + goto ARG; + case OP_FRAME: string = "FRAME\t"; + goto JMP; - default: - FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); - return vector; - NOARG: print_noarg(string); - break; - ARG: print_noarg(string); - @prin1(1, o); - break; - OPARG: print_oparg(string, n); - break; - OPARG_ARG: print_oparg_arg(string, n, o); - break; - } - goto BEGIN; + /* OP_CALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_CALL: string = "CALL\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The output values are left in VALUES. + */ + case OP_CALLG: string = "CALLG\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + + /* OP_FCALL n{arg} + Calls the function in the stack with N arguments which + have been also deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_STEPCALL: + case OP_FCALL: string = "FCALL\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_MCALL + Similar to FCALL, but gets the number of arguments from + the stack (They all have been deposited by OP_PUSHVALUES) + */ + case OP_MCALL: string = "MCALL"; + goto NOARG; + + /* OP_POPREQ + Extracts next required argument. + */ + case OP_POPREQ: string = "POP\tREQ"; + goto NOARG; + /* OP_NOMORE + Ensure there are no more arguments. + */ + case OP_NOMORE: string = "NOMORE"; + goto NOARG; + /* OP_POPOPT + Extracts next optional argument. + */ + case OP_POPOPT: string = "POP\tOPT"; + goto NOARG; + /* OP_POPREST + Extracts list of remaining arguments. + */ + case OP_POPREST: string = "POP\tREST"; + goto NOARG; + /* OP_PUSHKEYS + Parses the keyword arguments + */ + case OP_PUSHKEYS: string = "PUSH\tKEYS "; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_EXIT + Marks the end of a high level construct + */ + case OP_EXIT: print_noarg("EXIT"); + return vector; + /* OP_EXIT_FRAME + Marks the end of a high level construct (BLOCK, CATCH...) + */ + case OP_EXIT_FRAME: string = "EXIT\tFRAME"; + goto NOARG; + /* OP_EXIT_TAGBODY + Marks the end of a high level construct (TAGBODY) + */ + case OP_EXIT_TAGBODY: print_noarg("EXIT\tTAGBODY"); + return vector; + + case OP_FLET: vector = disassemble_flet(bytecodes, vector); + break; + case OP_LABELS: vector = disassemble_labels(bytecodes, vector); + break; + + /* OP_LFUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_LFUNCTION: string = "LOCFUNC\t"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_FUNCTION: string = "SYMFUNC\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_CLOSE name{arg} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_CLOSE: string = "CLOSE\t"; + GET_DATA(o, vector, data); + goto ARG; + + /* OP_GO n{arg}, tag-ndx{arg} + OP_QUOTE tag-name{symbol} + Jumps to the tag which is defined at the n-th position in + the lexical environment. TAG-NAME is kept for debugging + purposes. + */ + case OP_GO: string = "GO\t"; + GET_OPARG(n, vector); + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + goto OPARG_ARG; + + /* OP_RETURN n{arg} + Returns from the block whose record in the lexical environment + occuppies the n-th position. + */ + case OP_RETURN: string = "RETFROM"; + GET_OPARG(n, vector); + goto OPARG; + + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + case OP_THROW: string = "THROW"; + goto NOARG; + + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ label{arg}, value{object} + OP_JNEQ label{arg}, value{object} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of VALUES(0). + */ + case OP_JMP: string = "JMP\t"; + goto JMP; + case OP_JNIL: string = "JNIL\t"; + goto JMP; + case OP_JT: string = "JT\t"; + JMP: { GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG; + } + case OP_JEQL: string = "JEQL\t"; + goto JEQL; + case OP_JNEQL: string = "JNEQL\t"; + JEQL: { GET_DATA(o, vector, data); + GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + goto OPARG_ARG; + } + case OP_NOT: string = "NOT"; + goto NOARG; + + /* OP_UNBIND n{arg} + Undo "n" bindings of lexical variables. + */ + case OP_UNBIND: string = "UNBIND\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + case OP_UNBINDS: string = "UNBINDS\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + Binds a lexical or special variable to the either the + value of VALUES(0), to the first value of the stack, or + to the n-th value of VALUES(...). + */ + case OP_BIND: string = "BIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBIND: string = "PBIND\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBIND: string = "VBIND\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + case OP_BINDS: string = "BINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PBINDS: string = "PBINDS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VBINDS: string = "VBINDS\t"; + GET_OPARG(n, vector); + GET_DATA(o, vector, data); + goto OPARG_ARG; + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in VALUES(0) (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). + */ + case OP_SETQ: string = "SETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_PSETQ: string = "PSETQ\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_VSETQ: string = "VSETQ\t"; + GET_OPARG(m, vector); + o = ecl_make_fixnum(m); + GET_OPARG(n, vector); + goto OPARG_ARG; + case OP_SETQS: string = "SETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_PSETQS: string = "PSETQS\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_VSETQS: string = "VSETQS\t"; + GET_DATA(o, vector, data); + GET_OPARG(n, vector); + goto OPARG_ARG; + + case OP_PROGV: vector = disassemble_progv(bytecodes, vector); + break; + case OP_EXIT_PROGV: print_noarg("PROGV\tEXIT"); + return vector; + + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + */ + case OP_VALUES: string = "VALUES\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + case OP_NTHVAL: string = "NTHVAL\t"; + goto NOARG; + case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); + break; + case OP_PROTECT: string = "PROTECT\t"; + goto JMP; + case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; + goto NOARG; + case OP_PROTECT_EXIT: string = "PROTECT\tEXIT"; + goto NOARG; + case OP_NIL: string = "QUOTE\tNIL"; + goto NOARG; + case OP_PUSHNIL: string = "PUSH\t'NIL"; + goto NOARG; + case OP_STEPIN: string = "STEP\tIN,"; + GET_DATA(o, vector, data); + goto ARG; + case OP_STEPOUT: string = "STEP\tOUT"; + goto NOARG; + + case OP_CONS: string = "CONS"; goto NOARG; + case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; + case OP_CAR: string = "CAR\tREG0"; goto NOARG; + case OP_CDR: string = "CDR\tREG0"; goto NOARG; + case OP_LIST: string = "LIST\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_LISTA: string = "LIST*\t"; + GET_OPARG(n, vector); + goto OPARG; + case OP_CALLG1: string = "CALLG1\t"; + GET_DATA(o, vector, data); + goto ARG; + case OP_CALLG2: string = "CALLG2\t"; + GET_DATA(o, vector, data); + goto ARG; + + default: + FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1))); + return vector; + NOARG: print_noarg(string); + break; + ARG: print_noarg(string); + @prin1(1, o); + break; + OPARG: print_oparg(string, n); + break; + OPARG_ARG: print_oparg_arg(string, n, o); + break; + } + goto BEGIN; } cl_object si_bc_disassemble(cl_object v) { - if (ecl_t_of(v) == t_bclosure) { - v = v->bclosure.code; - } - if (ecl_t_of(v) == t_bytecodes) { - disassemble_lambda(v); - @(return v) - } - @(return ECL_NIL) + if (ecl_t_of(v) == t_bclosure) { + v = v->bclosure.code; + } + if (ecl_t_of(v) == t_bytecodes) { + disassemble_lambda(v); + @(return v) + } + @(return ECL_NIL) } cl_object si_bc_split(cl_object b) { - cl_object vector, data, name, lex = ECL_NIL; + cl_object vector, data, name, lex = ECL_NIL; - if (ecl_t_of(b) == t_bclosure) { - b = b->bclosure.code; - lex = b->bclosure.lex; - } - if (ecl_t_of(b) != t_bytecodes) { + if (ecl_t_of(b) == t_bclosure) { + b = b->bclosure.code; + lex = b->bclosure.lex; + } + if (ecl_t_of(b) != t_bytecodes) { vector = ECL_NIL; data = ECL_NIL; name = ECL_NIL; @@ -643,7 +643,7 @@ si_bc_split(cl_object b) data = cl_copy_seq(b->bytecodes.data); name = b->bytecodes.name; } - @(return lex vector data name) + @(return lex vector data name) } cl_object diff --git a/src/c/dpp.c b/src/c/dpp.c index 3dfabc4c2..32377f566 100755 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -17,54 +17,54 @@ /* - Usage: - dpp [in-file [out-file]] + Usage: + dpp [in-file [out-file]] - The file named in-file is preprocessed and the output will be - written to the file whose name is out-file. If in-file is "-" - program is read from standard input, while if out-file is "-" - C-program is written to standard output. + The file named in-file is preprocessed and the output will be + written to the file whose name is out-file. If in-file is "-" + program is read from standard input, while if out-file is "-" + C-program is written to standard output. - The function definition: + The function definition: - @(defun name ({var}* - [&optional {var | (var [initform [svar]])}*] - [&rest var] - [&key {var | - ({var | (keyword var)} [initform [svar]])}* - [&allow_other_keys]] - [&aux {var | (var [initform])}*]) + @(defun name ({var}* + [&optional {var | (var [initform [svar]])}*] + [&rest var] + [&key {var | + ({var | (keyword var)} [initform [svar]])}* + [&allow_other_keys]] + [&aux {var | (var [initform])}*]) - C-declaration + C-declaration - @ + @ - C-body + C-body - @) + @) - name can be either an identifier or a full C procedure header - enclosed in quotes ('). + name can be either an identifier or a full C procedure header + enclosed in quotes ('). - &optional may be abbreviated as &o. - &rest may be abbreviated as &r. - &key may be abbreviated as &k. - &allow_other_keys may be abbreviated as &aok. - &aux may be abbreviated as &a. + &optional may be abbreviated as &o. + &rest may be abbreviated as &r. + &key may be abbreviated as &k. + &allow_other_keys may be abbreviated as &aok. + &aux may be abbreviated as &a. - Each variable becomes a C variable. + Each variable becomes a C variable. - Each supplied-p parameter becomes a boolean C variable. + Each supplied-p parameter becomes a boolean C variable. - Initforms are C expressions. - If an expression contains non-alphanumeric characters, - it should be surrounded by backquotes (`). + Initforms are C expressions. + If an expression contains non-alphanumeric characters, + it should be surrounded by backquotes (`). - Function return: + Function return: - @(return {form}*) + @(return {form}*) */ @@ -113,9 +113,9 @@ int nreq; int the_env_defined = 0; struct optional { - char *o_var; - char *o_init; - char *o_svar; + char *o_var; + char *o_init; + char *o_svar; } optional[MAXOPT]; int nopt; @@ -124,17 +124,17 @@ char *rest_var; bool key_flag; struct keyword { - char *k_key; - char *k_var; - char *k_init; - char *k_svar; + char *k_key; + char *k_var; + char *k_init; + char *k_svar; } keyword[MAXKEY]; int nkey; bool allow_other_keys_flag; struct aux { - char *a_var; - char *a_init; + char *a_var; + char *a_init; } aux[MAXAUX]; int naux; @@ -144,511 +144,511 @@ int nres; void put_lineno(void) { - static int flag = 0; - if (flag) - fprintf(out, "#line %d\n", lineno); - else { - flag++; - fprintf(out, "#line %d \"%s\"\n", lineno, filename); - } + static int flag = 0; + if (flag) + fprintf(out, "#line %d\n", lineno); + else { + flag++; + fprintf(out, "#line %d \"%s\"\n", lineno, filename); + } } void error(char *s) { - printf("Error in line %d: %s.\n", lineno, s); - exit(1); + printf("Error in line %d: %s.\n", lineno, s); + exit(1); } void error_symbol(char *s) { - printf("Error in line %d: illegal symbol %s.\n", lineno, s); - exit(1); + printf("Error in line %d: illegal symbol %s.\n", lineno, s); + exit(1); } int readc(void) { - int c; + int c; - c = getc(in); - if (feof(in)) { - if (function != NULL) - error("unexpected end of file"); - exit(0); - } - if (c == '\n') { - lineno++; - tab = 0; - } else if (c == '\t') - tab++; - return(c); + c = getc(in); + if (feof(in)) { + if (function != NULL) + error("unexpected end of file"); + exit(0); + } + if (c == '\n') { + lineno++; + tab = 0; + } else if (c == '\t') + tab++; + return(c); } int nextc(void) { - int c; + int c; - while (isspace(c = readc())) - ; - return(c); + while (isspace(c = readc())) + ; + return(c); } void unreadc(int c) { - if (c == '\n') - --lineno; - else if (c == '\t') - --tab; - ungetc(c, in); + if (c == '\n') + --lineno; + else if (c == '\t') + --tab; + ungetc(c, in); } void put_tabs(int n) { - put_lineno(); - while (n--) - putc('\t', out); + put_lineno(); + while (n--) + putc('\t', out); } void pushc(int c) { - if (poolp >= &pool[POOLSIZE]) - error("buffer pool overflow"); - *poolp++ = c; + if (poolp >= &pool[POOLSIZE]) + error("buffer pool overflow"); + *poolp++ = c; } void pushstr(const char *s) { - while (*s) - pushc(*(s++)); + while (*s) + pushc(*(s++)); } int search_keyword(const char *name) { - int i; - char c[256]; + int i; + char c[256]; - for (i=0; name[i] && i<255; i++) - if (name[i] == '_') - c[i] = '-'; - else - c[i] = name[i]; - if (i == 255) - error("Too long keyword"); - c[i] = 0; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].name[0] == ':') - if (!strcasecmp(c, cl_symbols[i].name+1)) - return i; - } - printf("Keyword not found: %s.\n", c); - return 0; + for (i=0; name[i] && i<255; i++) + if (name[i] == '_') + c[i] = '-'; + else + c[i] = name[i]; + if (i == 255) + error("Too long keyword"); + c[i] = 0; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].name[0] == ':') + if (!strcasecmp(c, cl_symbols[i].name+1)) + return i; + } + printf("Keyword not found: %s.\n", c); + return 0; } char * search_symbol(char *name, int *symbol_code, int code) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (!strcasecmp(name, cl_symbols[i].name)) { - name = poolp; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (!strcasecmp(name, cl_symbols[i].name)) { + name = poolp; if (code) { pushstr("ecl_make_fixnum(/*"); pushstr(cl_symbols[i].name); - pushstr("*/"); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); + pushstr("*/"); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); } else if (i == 0) { - pushstr("ECL_NIL"); - pushc(0); - } else { - pushstr("ECL_SYM(\""); - pushstr(cl_symbols[i].name); - pushstr("\","); - if (i >= 1000) - pushc((i / 1000) % 10 + '0'); - if (i >= 100) - pushc((i / 100) % 10 + '0'); - if (i >= 10) - pushc((i / 10) % 10 + '0'); - pushc(i % 10 + '0'); - pushstr(")"); - pushc(0); - } - if (symbol_code) - *symbol_code = i; - return name; - } - } - return NULL; + pushstr("ECL_NIL"); + pushc(0); + } else { + pushstr("ECL_SYM(\""); + pushstr(cl_symbols[i].name); + pushstr("\","); + if (i >= 1000) + pushc((i / 1000) % 10 + '0'); + if (i >= 100) + pushc((i / 100) % 10 + '0'); + if (i >= 10) + pushc((i / 10) % 10 + '0'); + pushc(i % 10 + '0'); + pushstr(")"); + pushc(0); + } + if (symbol_code) + *symbol_code = i; + return name; + } + } + return NULL; } char * read_symbol(int code) { - char c, *name = poolp; + char c, *name = poolp; char end = code? ']' : '\''; - c = readc(); - while (c != end) { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - pushc(0); + c = readc(); + while (c != end) { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + pushc(0); - name = search_symbol(poolp = name, 0, code); - if (name == NULL) { - name = poolp; - printf("\nUnknown symbol: %s\n", name); - pushstr("unknown"); - } - return name; + name = search_symbol(poolp = name, 0, code); + if (name == NULL) { + name = poolp; + printf("\nUnknown symbol: %s\n", name); + pushstr("unknown"); + } + return name; } char * search_function(char *name) { - int i; - for (i = 0; cl_symbols[i].name != NULL; i++) { - if (cl_symbols[i].translation != NULL && - !strcasecmp(name, cl_symbols[i].name)) { - name = poolp; - pushstr(cl_symbols[i].translation); - pushc(0); - return name; - } - } - return name; + int i; + for (i = 0; cl_symbols[i].name != NULL; i++) { + if (cl_symbols[i].translation != NULL && + !strcasecmp(name, cl_symbols[i].name)) { + name = poolp; + pushstr(cl_symbols[i].translation); + pushc(0); + return name; + } + } + return name; } char * read_function() { - char c, *name = poolp; + char c, *name = poolp; - c = readc(); - if (c == '"') { - c = readc(); - while (c != '"') { - pushc(c); - c = readc(); - } - pushc(0); - return name; - } - while (c != '(' && !isspace(c) && c != ')' && c != ',') { - if (c == '_') c = '-'; - pushc(c); - c = readc(); - } - unreadc(c); - pushc(0); - return name; + c = readc(); + if (c == '"') { + c = readc(); + while (c != '"') { + pushc(c); + c = readc(); + } + pushc(0); + return name; + } + while (c != '(' && !isspace(c) && c != ')' && c != ',') { + if (c == '_') c = '-'; + pushc(c); + c = readc(); + } + unreadc(c); + pushc(0); + return name; } char * translate_function(char *name) { - char *output = search_function(name); - if (output == NULL) { - printf("\nUnknown function: %s\n", name); - pushstr("unknown"); - output = poolp; - } - return output; + char *output = search_function(name); + if (output == NULL) { + printf("\nUnknown function: %s\n", name); + pushstr("unknown"); + output = poolp; + } + return output; } char * read_token(void) { - int c; - int left_paren = 0; - char *p; + int c; + int left_paren = 0; + char *p; - p = poolp; - c = readc(); - while (isspace(c)) - c = readc(); - do { - if (c == '(') { - left_paren++; - pushc(c); - } else if (c == ')') { - if (left_paren == 0) { - break; - } else { - left_paren--; - pushc(c); - } - } else if (isspace(c) && left_paren == 0) { - do - c = readc(); - while (isspace(c)); - break; - } else if (c == '@') { - c = readc(); - if (c == '\'') { - (void)read_symbol(0); - poolp--; - } else if (c == '[') { - (void)read_symbol(1); - poolp--; - } else if (c == '@') { - pushc(c); - } else { - char *name; - unreadc(c); - poolp = name = read_function(); - (void)translate_function(poolp); - } - } else { - pushc(c); - } - c = readc(); - } while (1); - unreadc(c); - pushc('\0'); - return(p); + p = poolp; + c = readc(); + while (isspace(c)) + c = readc(); + do { + if (c == '(') { + left_paren++; + pushc(c); + } else if (c == ')') { + if (left_paren == 0) { + break; + } else { + left_paren--; + pushc(c); + } + } else if (isspace(c) && left_paren == 0) { + do + c = readc(); + while (isspace(c)); + break; + } else if (c == '@') { + c = readc(); + if (c == '\'') { + (void)read_symbol(0); + poolp--; + } else if (c == '[') { + (void)read_symbol(1); + poolp--; + } else if (c == '@') { + pushc(c); + } else { + char *name; + unreadc(c); + poolp = name = read_function(); + (void)translate_function(poolp); + } + } else { + pushc(c); + } + c = readc(); + } while (1); + unreadc(c); + pushc('\0'); + return(p); } void reset(void) { - int i; + int i; the_env_defined = 0; - poolp = pool; - function = NULL; - function_symbol = ""; - function_c_name = ""; - nreq = 0; - for (i = 0; i < MAXREQ; i++) - required[i] = NULL; - nopt = 0; - for (i = 0; i < MAXOPT; i++) - optional[i].o_var - = optional[i].o_init - = optional[i].o_svar - = NULL; - rest_flag = FALSE; - rest_var = "ARGS"; - key_flag = FALSE; - nkey = 0; - for (i = 0; i < MAXKEY; i++) - keyword[i].k_key - = keyword[i].k_var - = keyword[i].k_init - = keyword[i].k_svar - = NULL; - allow_other_keys_flag = FALSE; - naux = 0; - for (i = 0; i < MAXAUX; i++) - aux[i].a_var - = aux[i].a_init - = NULL; + poolp = pool; + function = NULL; + function_symbol = ""; + function_c_name = ""; + nreq = 0; + for (i = 0; i < MAXREQ; i++) + required[i] = NULL; + nopt = 0; + for (i = 0; i < MAXOPT; i++) + optional[i].o_var + = optional[i].o_init + = optional[i].o_svar + = NULL; + rest_flag = FALSE; + rest_var = "ARGS"; + key_flag = FALSE; + nkey = 0; + for (i = 0; i < MAXKEY; i++) + keyword[i].k_key + = keyword[i].k_var + = keyword[i].k_init + = keyword[i].k_svar + = NULL; + allow_other_keys_flag = FALSE; + naux = 0; + for (i = 0; i < MAXAUX; i++) + aux[i].a_var + = aux[i].a_init + = NULL; } void get_function(void) { - function = read_function(); - function_symbol = search_symbol(function, &function_code, 0); - if (function_symbol == NULL) { - function_symbol = poolp; - pushstr("ECL_NIL"); - pushc('\0'); - } - function_c_name = translate_function(function); + function = read_function(); + function_symbol = search_symbol(function, &function_code, 0); + if (function_symbol == NULL) { + function_symbol = poolp; + pushstr("ECL_NIL"); + pushc('\0'); + } + function_c_name = translate_function(function); } void get_lambda_list(void) { - int c; - char *p; + int c; + char *p; - if ((c = nextc()) != '(') - error("( expected"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _OPT; - } - unreadc(c); - p = read_token(); - if (nreq >= MAXREQ) - error("too many required variables"); - required[nreq++] = p; - } + if ((c = nextc()) != '(') + error("( expected"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _OPT; + } + unreadc(c); + p = read_token(); + if (nreq >= MAXREQ) + error("too many required variables"); + required[nreq++] = p; + } _OPT: - if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) - goto _REST; - for (;; nopt++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - goto _REST; - } - if (nopt >= MAXOPT) - error("too many optional argument"); - if (c == '(') { - optional[nopt].o_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - optional[nopt].o_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - optional[nopt].o_var = read_token(); - } - } + if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) + goto _REST; + for (;; nopt++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto _REST; + } + if (nopt >= MAXOPT) + error("too many optional argument"); + if (c == '(') { + optional[nopt].o_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + optional[nopt].o_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + optional[nopt].o_var = read_token(); + } + } _REST: - if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) - goto _KEY; - rest_flag = TRUE; - if ((c = nextc()) == ')' || c == '&') - error("&rest var missing"); - unreadc(c); - rest_var = read_token(); - if ((c = nextc()) == ')') - return; - if (c != '&') - error("& expected"); - p = read_token(); + if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) + goto _KEY; + rest_flag = TRUE; + if ((c = nextc()) == ')' || c == '&') + error("&rest var missing"); + unreadc(c); + rest_var = read_token(); + if ((c = nextc()) == ')') + return; + if (c != '&') + error("& expected"); + p = read_token(); _KEY: - if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) - goto _AUX; - key_flag = TRUE; - for (;; nkey++) { - if ((c = nextc()) == ')') - return; - if (c == '&') { - p = read_token(); - if (strcmp(p, "allow_other_keys") == 0 || - strcmp(p, "aok") == 0) { - allow_other_keys_flag = TRUE; - if ((c = nextc()) == ')') - return; - if (c != '&') - error("& expected"); - p = read_token(); - } - goto _AUX; - } - if (nkey >= MAXKEY) - error("too many optional argument"); - if (c == '(') { - if ((c = nextc()) == '(') { - p = read_token(); - if (p[0] != ':' || p[1] == '\0') - error("keyword expected"); - keyword[nkey].k_key = p + 1; - keyword[nkey].k_var = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_init = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - keyword[nkey].k_svar = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - keyword[nkey].k_key - = keyword[nkey].k_var - = read_token(); - } - } + if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) + goto _AUX; + key_flag = TRUE; + for (;; nkey++) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + if (strcmp(p, "allow_other_keys") == 0 || + strcmp(p, "aok") == 0) { + allow_other_keys_flag = TRUE; + if ((c = nextc()) == ')') + return; + if (c != '&') + error("& expected"); + p = read_token(); + } + goto _AUX; + } + if (nkey >= MAXKEY) + error("too many optional argument"); + if (c == '(') { + if ((c = nextc()) == '(') { + p = read_token(); + if (p[0] != ':' || p[1] == '\0') + error("keyword expected"); + keyword[nkey].k_key = p + 1; + keyword[nkey].k_var = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_init = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + keyword[nkey].k_svar = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + keyword[nkey].k_key + = keyword[nkey].k_var + = read_token(); + } + } _AUX: - if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) - error("illegal lambda-list keyword"); - for (;;) { - if ((c = nextc()) == ')') - return; - if (c == '&') - error("illegal lambda-list keyword"); - if (naux >= MAXAUX) - error("too many auxiliary variable"); - if (c == '(') { - aux[naux].a_var = read_token(); - if ((c = nextc()) == ')') - continue; - unreadc(c); - aux[naux].a_init = read_token(); - if (nextc() != ')') - error(") expected"); - } else { - unreadc(c); - aux[naux].a_var = read_token(); - } - naux++; - } + if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) + error("illegal lambda-list keyword"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') + error("illegal lambda-list keyword"); + if (naux >= MAXAUX) + error("too many auxiliary variable"); + if (c == '(') { + aux[naux].a_var = read_token(); + if ((c = nextc()) == ')') + continue; + unreadc(c); + aux[naux].a_init = read_token(); + if (nextc() != ')') + error(") expected"); + } else { + unreadc(c); + aux[naux].a_var = read_token(); + } + naux++; + } } void get_return(void) { - int c; + int c; - nres = 0; - for (;;) { - if ((c = nextc()) == ')') - return; - unreadc(c); - result[nres++] = read_token(); - } + nres = 0; + for (;;) { + if ((c = nextc()) == ')') + return; + unreadc(c); + result[nres++] = read_token(); + } } void put_fhead(void) { - int i; + int i; - put_lineno(); - fprintf(out, "cl_object %s(cl_narg narg", function_c_name); - for (i = 0; i < nreq; i++) - fprintf(out, ", cl_object %s", required[i]); - if (nopt > 0 || rest_flag || key_flag) - fprintf(out, ", ..."); - fprintf(out, ")\n{\n"); + put_lineno(); + fprintf(out, "cl_object %s(cl_narg narg", function_c_name); + for (i = 0; i < nreq; i++) + fprintf(out, ", cl_object %s", required[i]); + if (nopt > 0 || rest_flag || key_flag) + fprintf(out, ", ..."); + fprintf(out, ")\n{\n"); } void @@ -674,9 +674,9 @@ put_declaration(void) if (nkey) { fprintf(out, "\tstatic cl_object KEYS[%d] = {", nkey); for (i = 0; i < nkey; i++) { - if (i > 0) - fprintf(out, ", "); - fprintf(out, "(cl_object)(cl_symbols+%d)", search_keyword(keyword[i].k_key)); + if (i > 0) + fprintf(out, ", "); + fprintf(out, "(cl_object)(cl_symbols+%d)", search_keyword(keyword[i].k_key)); } fprintf(out, "};\n"); } else { @@ -703,19 +703,19 @@ put_declaration(void) put_lineno(); /* We do this because Microsoft VC++ does not support arrays of zero size */ if (nkey) { - fprintf(out, "\tcl_object KEY_VARS[%d];\n", 2*nkey); + fprintf(out, "\tcl_object KEY_VARS[%d];\n", 2*nkey); } else { - fprintf(out, "\tcl_object *KEY_VARS = NULL;\n"); + fprintf(out, "\tcl_object *KEY_VARS = NULL;\n"); } } put_lineno(); if (simple_varargs) - fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); + fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); else - fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), - nreq); + fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), + nreq); put_lineno(); fprintf(out, "\tif (ecl_unlikely(narg < %d", nreq); if (nopt > 0 && !rest_flag && !key_flag) { @@ -727,22 +727,22 @@ put_declaration(void) fprintf(out, "\tif (narg > %d) {\n", nreq+i); put_lineno(); fprintf(out, simple_varargs? - "\t\t%s = va_arg(%s,cl_object);\n": - "\t\t%s = ecl_va_arg(%s);\n", - optional[i].o_var, rest_var); + "\t\t%s = va_arg(%s,cl_object);\n": + "\t\t%s = ecl_va_arg(%s);\n", + optional[i].o_var, rest_var); if (optional[i].o_svar) { - put_lineno(); - fprintf(out, "\t\t%s = TRUE;\n", optional[i].o_svar); + put_lineno(); + fprintf(out, "\t\t%s = TRUE;\n", optional[i].o_svar); } put_lineno(); fprintf(out, "\t} else {\n"); put_lineno(); fprintf(out, "\t\t%s = %s;\n", - optional[i].o_var, - optional[i].o_init == NULL ? "ECL_NIL" : optional[i].o_init); + optional[i].o_var, + optional[i].o_init == NULL ? "ECL_NIL" : optional[i].o_init); if (optional[i].o_svar) { - put_lineno(); - fprintf(out, "\t\t%s = FALSE;\n", optional[i].o_svar); + put_lineno(); + fprintf(out, "\t\t%s = FALSE;\n", optional[i].o_svar); } put_lineno(); fprintf(out, "\t}\n"); @@ -750,67 +750,67 @@ put_declaration(void) if (key_flag) { put_lineno(); fprintf(out, "\tcl_parse_key(ARGS, %d, KEYS, KEY_VARS, NULL, %d);\n", - nkey, allow_other_keys_flag); + nkey, allow_other_keys_flag); for (i = 0; i < nkey; i++) { - put_lineno(); - fprintf(out, "\tif (KEY_VARS[%d]==ECL_NIL) {\n", nkey+i); - if (keyword[i].k_init != NULL) { - put_lineno(); - fprintf(out, "\t %s = %s;\n", keyword[i].k_var, keyword[i].k_init); - } else { - put_lineno(); - fprintf(out, "\t %s = ECL_NIL;\n", keyword[i].k_var); - } - if (keyword[i].k_svar != NULL) { - put_lineno(); - fprintf(out, "\t %s = FALSE;\n", keyword[i].k_svar); - } - fprintf(out, "\t} else {\n"); - if (keyword[i].k_svar != NULL) { - put_lineno(); - fprintf(out, "\t %s = TRUE;\n", keyword[i].k_svar); - } - put_lineno(); - fprintf(out, "\t %s = KEY_VARS[%d];\n\t}\n", keyword[i].k_var, i); + put_lineno(); + fprintf(out, "\tif (KEY_VARS[%d]==ECL_NIL) {\n", nkey+i); + if (keyword[i].k_init != NULL) { + put_lineno(); + fprintf(out, "\t %s = %s;\n", keyword[i].k_var, keyword[i].k_init); + } else { + put_lineno(); + fprintf(out, "\t %s = ECL_NIL;\n", keyword[i].k_var); + } + if (keyword[i].k_svar != NULL) { + put_lineno(); + fprintf(out, "\t %s = FALSE;\n", keyword[i].k_svar); + } + fprintf(out, "\t} else {\n"); + if (keyword[i].k_svar != NULL) { + put_lineno(); + fprintf(out, "\t %s = TRUE;\n", keyword[i].k_svar); + } + put_lineno(); + fprintf(out, "\t %s = KEY_VARS[%d];\n\t}\n", keyword[i].k_var, i); } } } for (i = 0; i < naux; i++) { put_lineno(); fprintf(out, "\t%s = %s;\n", aux[i].a_var, - aux[i].a_init == NULL ? "ECL_NIL" : aux[i].a_init); + aux[i].a_init == NULL ? "ECL_NIL" : aux[i].a_init); } } void put_return(void) { - int i, t; + int i, t; - t = tab_save+1; + t = tab_save+1; fprintf(out, "{\n"); if (!the_env_defined) { put_tabs(t); fprintf(out, "const cl_env_ptr the_env = ecl_process_env();\n"); } - if (nres == 0) { + if (nres == 0) { fprintf(out, "the_env->nvalues = 0; return ECL_NIL;\n"); - } else { - put_tabs(t); - for (i = 0; i < nres; i++) { - put_tabs(t); - fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); - } - put_tabs(t); - fprintf(out, "the_env->nvalues = %d;\n", nres); - for (i = nres-1; i > 0; i--) { - put_tabs(t); - fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); - } - put_tabs(t); - fprintf(out, "return __value0;\n"); - } + } else { + put_tabs(t); + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); + } + put_tabs(t); + fprintf(out, "the_env->nvalues = %d;\n", nres); + for (i = nres-1; i > 0; i--) { + put_tabs(t); + fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); + } + put_tabs(t); + fprintf(out, "return __value0;\n"); + } put_tabs(tab_save); fprintf(out, "}\n"); } @@ -818,116 +818,116 @@ put_return(void) int jump_to_at(void) { - int c; + int c; GO_ON: - while ((c = readc()) != '@') - putc(c, out); - if ((c = readc()) == '@') { - putc(c, out); - goto GO_ON; - } - return c; + while ((c = readc()) != '@') + putc(c, out); + if ((c = readc()) == '@') { + putc(c, out); + goto GO_ON; + } + return c; } void main_loop(void) { - int c; - int in_defun=0; - char *p; + int c; + int in_defun=0; + char *p; - lineno = 1; + lineno = 1; - reset(); - put_lineno(); + reset(); + put_lineno(); LOOP: - c = jump_to_at(); - if (c == ')') { - if (!in_defun) - error("unmatched @) found"); - in_defun = 0; - putc('}',out); - reset(); - goto LOOP; - } else if (c == '\'') { - char *p; - poolp = pool; - p = read_symbol(0); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c == '[') { - char *p; - poolp = pool; - p = read_symbol(1); - pushc('\0'); - fprintf(out,"%s",p); - goto LOOP; - } else if (c != '(') { - char *p; - unreadc(c); - poolp = pool; - poolp = p = read_function(); - fprintf(out,"%s",translate_function(poolp)); - goto LOOP; - } - p = read_token(); - if (strcmp(p, "defun") == 0) { - if (in_defun) - error("@) expected before new function definition"); - in_defun = 1; - get_function(); - get_lambda_list(); - put_fhead(); - put_lineno(); - c = jump_to_at(); - put_declaration(); - put_lineno(); - } else if (strcmp(p, "return") == 0) { - tab_save = tab; - get_return(); - put_return(); - } else - error_symbol(p); - goto LOOP; + c = jump_to_at(); + if (c == ')') { + if (!in_defun) + error("unmatched @) found"); + in_defun = 0; + putc('}',out); + reset(); + goto LOOP; + } else if (c == '\'') { + char *p; + poolp = pool; + p = read_symbol(0); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c == '[') { + char *p; + poolp = pool; + p = read_symbol(1); + pushc('\0'); + fprintf(out,"%s",p); + goto LOOP; + } else if (c != '(') { + char *p; + unreadc(c); + poolp = pool; + poolp = p = read_function(); + fprintf(out,"%s",translate_function(poolp)); + goto LOOP; + } + p = read_token(); + if (strcmp(p, "defun") == 0) { + if (in_defun) + error("@) expected before new function definition"); + in_defun = 1; + get_function(); + get_lambda_list(); + put_fhead(); + put_lineno(); + c = jump_to_at(); + put_declaration(); + put_lineno(); + } else if (strcmp(p, "return") == 0) { + tab_save = tab; + get_return(); + put_return(); + } else + error_symbol(p); + goto LOOP; } int main(int argc, char **argv) { - char outfile[BUFSIZ]; + char outfile[BUFSIZ]; #ifdef _MSC_VER - char *p; + char *p; #endif - if (argc < 2 || !strcmp(argv[1],"-")) { - in = stdin; - strcpy(filename, "-"); - } else { - in = fopen(argv[1],"r"); - strncpy(filename, argv[1], BUFSIZ-1); - filename[BUFSIZ-1] = '\0'; - } + if (argc < 2 || !strcmp(argv[1],"-")) { + in = stdin; + strcpy(filename, "-"); + } else { + in = fopen(argv[1],"r"); + strncpy(filename, argv[1], BUFSIZ-1); + filename[BUFSIZ-1] = '\0'; + } #ifdef _MSC_VER - /* Convert all backslashes in filename into slashes, - * to avoid warnings when compiling with MSVC - */ - for ( p=filename; *p; p++ ) - if ( *p == '\\' ) - *p = '/'; + /* Convert all backslashes in filename into slashes, + * to avoid warnings when compiling with MSVC + */ + for ( p=filename; *p; p++ ) + if ( *p == '\\' ) + *p = '/'; #endif - if (argc < 3 || !strcmp(argv[2],"-")) { - out = stdout; - strcpy(outfile, "-"); - } else { - out = fopen(argv[2],"w"); - strncpy(outfile, argv[2], BUFSIZ-1); - outfile[BUFSIZ-1] = '\0'; - } - if (in == NULL) - error("can't open input file"); - if (out == NULL) - error("can't open output file"); - printf("dpp: %s -> %s\n", filename, outfile); - main_loop(); - return 0; + if (argc < 3 || !strcmp(argv[2],"-")) { + out = stdout; + strcpy(outfile, "-"); + } else { + out = fopen(argv[2],"w"); + strncpy(outfile, argv[2], BUFSIZ-1); + outfile[BUFSIZ-1] = '\0'; + } + if (in == NULL) + error("can't open input file"); + if (out == NULL) + error("can't open output file"); + printf("dpp: %s -> %s\n", filename, outfile); + main_loop(); + return 0; } diff --git a/src/c/earith.d b/src/c/earith.d index 5481cb365..fbe288581 100644 --- a/src/c/earith.d +++ b/src/c/earith.d @@ -17,27 +17,27 @@ /* - EXTENDED_MUL and EXTENDED_DIV perform 32 bit multiplication and - division, respectively. + EXTENDED_MUL and EXTENDED_DIV perform 32 bit multiplication and + division, respectively. - EXTENDED_MUL(D,Q,R,HP,LP) - calculates D*Q+R and saves the result into the locations HP and LP. - D, Q, and R are 32 bit non-negative integers and HP and LP are - word addresses. The word at LP will contain the lower 31 (not 32) - bits of the result and its most significant bit is set 0. The word - at HP will contain the rest of the result and its MSB is also set 0. + EXTENDED_MUL(D,Q,R,HP,LP) + calculates D*Q+R and saves the result into the locations HP and LP. + D, Q, and R are 32 bit non-negative integers and HP and LP are + word addresses. The word at LP will contain the lower 31 (not 32) + bits of the result and its most significant bit is set 0. The word + at HP will contain the rest of the result and its MSB is also set 0. - EXTENDED_DIV(D,H,L,QP,RP) - divides [H:L] by D and saves the quotient and the remainder into - the locations QP and RP, respectively. D, H, L are 32 bit non-negative - integers and QP and RP are word addresses. Here, [H:L] means the - 64 bit integer (imaginary) represented by H and L as follows. + EXTENDED_DIV(D,H,L,QP,RP) + divides [H:L] by D and saves the quotient and the remainder into + the locations QP and RP, respectively. D, H, L are 32 bit non-negative + integers and QP and RP are word addresses. Here, [H:L] means the + 64 bit integer (imaginary) represented by H and L as follows. - 63 62 31 30 0 - |0|0||| + 63 62 31 30 0 + |0|0||| - Although [H:L] is 64 bits, you can assume that the quotient is always - represented as 32 bit non-negative integer. + Although [H:L] is 64 bits, you can assume that the quotient is always + represented as 32 bit non-negative integer. */ #include @@ -47,7 +47,7 @@ static void extended_mul(int d, int q, int r, int *hp, int *lp) { - long long int ld, lq, lr, z; + long long int ld, lq, lr, z; int zh, zl; ld = d; @@ -63,15 +63,15 @@ extended_mul(int d, int q, int r, int *hp, int *lp) static void extended_div(int d, int h, int l, int *qp, int *rp) { - long long int lh, ld, ll; + long long int lh, ld, ll; - ld = d; - lh = h; - ll = l; - lh = (lh << 31LL); - lh = (lh | ll); - *qp = (lh/ld); - *rp = (lh%ld); + ld = d; + lh = h; + ll = l; + lh = (lh << 31LL); + lh = (lh | ll); + *qp = (lh/ld); + *rp = (lh%ld); } #endif /* CONVEX */ @@ -80,36 +80,36 @@ extended_div(int d, int h, int l, int *qp, int *rp) static void extended_mul(int d, int q, int r, int *hp, int *lp) { asm("pushl %ecx"); - asm("movl 8(%ebp),%eax"); - asm("mull 12(%ebp)"); - asm("addl 16(%ebp),%eax"); - asm("adcl $0,%edx"); - asm("shll $1,%edx"); - asm("btrl $31,%eax"); - asm("adcl $0,%edx"); - asm("movl 20(%ebp),%ecx"); - asm("movl %edx, (%ecx)"); - asm("movl 24(%ebp), %ecx"); - asm("movl %eax, (%ecx)"); - asm("popl %ecx"); + asm("movl 8(%ebp),%eax"); + asm("mull 12(%ebp)"); + asm("addl 16(%ebp),%eax"); + asm("adcl $0,%edx"); + asm("shll $1,%edx"); + asm("btrl $31,%eax"); + asm("adcl $0,%edx"); + asm("movl 20(%ebp),%ecx"); + asm("movl %edx, (%ecx)"); + asm("movl 24(%ebp), %ecx"); + asm("movl %eax, (%ecx)"); + asm("popl %ecx"); } static void extended_div(int d, int h, int l, int *qp, int *rp) { - asm("pushl %ebx"); - asm("movl 12(%ebp),%edx"); - asm("movl 16(%ebp),%eax"); - asm("btl $0,%edx"); - asm("jae 1f"); - asm("btsl $31,%eax"); - asm("1: shrl $1,%edx"); - asm("idivl 8(%ebp)"); - asm("movl 20(%ebp),%ebx"); - asm("movl %eax,(%ebx)"); - asm("movl 24(%ebp),%ebx"); - asm("movl %edx,(%ebx)"); - asm("popl %ebx"); + asm("pushl %ebx"); + asm("movl 12(%ebp),%edx"); + asm("movl 16(%ebp),%eax"); + asm("btl $0,%edx"); + asm("jae 1f"); + asm("btsl $31,%eax"); + asm("1: shrl $1,%edx"); + asm("idivl 8(%ebp)"); + asm("movl 20(%ebp),%ebx"); + asm("movl %eax,(%ebx)"); + asm("movl 24(%ebp),%ebx"); + asm("movl %edx,(%ebx)"); + asm("popl %ebx"); } #endif /* i386 */ @@ -119,57 +119,57 @@ static void extended_mul(int d, int q, int r, int *hp, int *lp) { /* d=L750+20, q=L750+24, etc. */ - asm(" get r0,L750+20(r13)"); /* get an argument */ - asm(" mts r10,r0"); /* put in MQ */ - asm(" get r2,L750+24(r13)"); /* get the other argument */ - asm(" s r0,r0"); /* zero partial product. set carry to 1. */ + asm(" get r0,L750+20(r13)"); /* get an argument */ + asm(" mts r10,r0"); /* put in MQ */ + asm(" get r2,L750+24(r13)"); /* get the other argument */ + asm(" s r0,r0"); /* zero partial product. set carry to 1. */ asm(" m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2 - m r0,r2"); + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2 + m r0,r2"); /* Now (r0)//mq has the 64 bit product; overflow is ignored. */ - asm(" mfs r10,r2"); /* set r2 = low order word of result - * so product is in (r0)//(r2). - */ + asm(" mfs r10,r2"); /* set r2 = low order word of result + * so product is in (r0)//(r2). + */ /* * Force product into two single precision words. */ asm(" get r3,$1f - sli r0,1 - ar2,r2 - bnc0r r3"); /* branch if carry = 0 */ + sli r0,1 + ar2,r2 + bnc0r r3"); /* branch if carry = 0 */ asm(" oil r0,r0,1 - 1: - sri r2,1"); + 1: + sri r2,1"); /* Now add in the third argument. */ asm(" get r4,$2f - get r3,L750+28(r13) - a r2,r3 + get r3,L750+28(r13) + a r2,r3 - bnmr r4"); /* branch if not minus */ + bnmr r4"); /* branch if not minus */ asm(" clrbu r2,0 - lis r3,1 - a r0,r3 - 2: + lis r3,1 + a r0,r3 + 2: - get r3,L750+32(r13) - put r0,0(r3) - get r3,L750+36(r13) - put r2,0(r3) - "); + get r3,L750+32(r13) + put r0,0(r3) + get r3,L750+36(r13) + put r2,0(r3) + "); } static void @@ -177,62 +177,62 @@ extended_div(int d, int h, int l, int *qp, int *rp) { /* d=L754+20, h=L754+24, etc. */ /* Move arguments into registers. */ - asm(" get r0,L754+28(r13)"); /* Low order word of dividend. */ - asm(" get r2,L754+24(r13)"); /* High order word of dividend. */ + asm(" get r0,L754+28(r13)"); /* Low order word of dividend. */ + asm(" get r2,L754+24(r13)"); /* High order word of dividend. */ asm(" mttbil r2,15 - mftbiu r0,0 - sri r2,1 - mts r10,r0 - get r3,L754+20(r13)") /* Divisor. */ + mftbiu r0,0 + sri r2,1 + mts r10,r0 + get r3,L754+20(r13)") /* Divisor. */ /* Perform 32 steps of division. */ asm(" d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3 - d r2,r3"); + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3 + d r2,r3"); /* Now MQ has the quotient, R2 the remainder, and R3 is * the unchanged divisor. */ - asm(" mttbiu r2,0"); /* Do add-back if necessary. */ + asm(" mttbiu r2,0"); /* Do add-back if necessary. */ asm(" jntb 1f - a r2,r3 - 1: - mfs r10,r0 - c r2,r3"); /* Remainder : divisor. */ + a r2,r3 + 1: + mfs r10,r0 + c r2,r3"); /* Remainder : divisor. */ asm(" jne 2f - inc r0,1 - x r2,r2 - 2:"); + inc r0,1 + x r2,r2 + 2:"); /* Now r0 has the quotient and r2 has the remainder. */ - asm(" get r3,L754+32(r13)"); /* Quotient address. */ + asm(" get r3,L754+32(r13)"); /* Quotient address. */ asm(" put r0,0(r3)"); - asm(" get r3,L754+36(r13)"); /* Remainder address. */ + asm(" get r3,L754+36(r13)"); /* Remainder address. */ asm(" put r2,0(r3)"); } @@ -243,32 +243,32 @@ extended_div(int d, int h, int l, int *qp, int *rp) static void extended_mul(int d, int q, int r, int *hp, int *lp) { - asm(" move.l d2,-(sp) - clr.l d2 - move.l (8,fp),d0 - mulu.l (12,fp),d1:d0 - add.l (16,fp),d0 - addx.l d2,d1 - lsl.l #1,d0 - roxl.l #1,d1 - lsr.l #1,d0 - move.l (20,fp),a0 - move.l d1,(a0) - move.l (24,a6),a0 - move.l d0,(a0)"); + asm(" move.l d2,-(sp) + clr.l d2 + move.l (8,fp),d0 + mulu.l (12,fp),d1:d0 + add.l (16,fp),d0 + addx.l d2,d1 + lsl.l #1,d0 + roxl.l #1,d1 + lsr.l #1,d0 + move.l (20,fp),a0 + move.l d1,(a0) + move.l (24,a6),a0 + move.l d0,(a0)"); } static void extended_div(int d, int h, int l, int *qp, int *rp) { - asm("movem.l (12,fp),#0x303 - lsl.l #1,d1 - lsr.l #1,d0 - roxr.l #1,d1 - divu.l (8,fp),d0:d1 - move.l d0,(a1) - move.l d1,(a0) - "); + asm("movem.l (12,fp),#0x303 + lsl.l #1,d1 + lsr.l #1,d0 + roxr.l #1,d1 + divu.l (8,fp),d0:d1 + move.l d0,(a1) + move.l d1,(a0) + "); } #endif /* NEWS || MAC */ @@ -280,65 +280,65 @@ extended_div(int d, int h, int l, int *qp, int *rp) version 2.1.d dated 7/13/89 15:31 EDT */ /* Register names: -#define v0 $2 return value -#define v1 $3 -#define a0 $4 argument registers -#define a1 $5 -#define a2 $6 -#define a3 $7 -#define t7 $15 +#define v0 $2 return value +#define v1 $3 +#define a0 $4 argument registers +#define a1 $5 +#define a2 $6 +#define a3 $7 +#define t7 $15 */ static void extended_mul(unsigned int d, unsigned int q, unsigned int r, unsigned int *hp, - unsigned int *lp) + unsigned int *lp) { - asm("mult $4, $5"); /* [hi:lo] = d * q */ - asm("mfhi $5"); /* a1 = hi */ - asm("sll $5, 1"); - asm("mflo $4"); - asm("srl $15, $4, 31"); - asm("and $4, 0x7fffffff"); - asm("or $5, $15"); - asm("addu $4, $6"); /* [a1:a0] += r */ - asm("srl $15, $4, 31"); - asm("and $4, 0x7fffffff"); - asm("addu $5, $15"); - asm("sw $5, 0($7)"); /* *hp = a1 */ + asm("mult $4, $5"); /* [hi:lo] = d * q */ + asm("mfhi $5"); /* a1 = hi */ + asm("sll $5, 1"); + asm("mflo $4"); + asm("srl $15, $4, 31"); + asm("and $4, 0x7fffffff"); + asm("or $5, $15"); + asm("addu $4, $6"); /* [a1:a0] += r */ + asm("srl $15, $4, 31"); + asm("and $4, 0x7fffffff"); + asm("addu $5, $15"); + asm("sw $5, 0($7)"); /* *hp = a1 */ #ifdef __GNUC__ - asm("lw $7, %0" :: "g" (lp)); + asm("lw $7, %0" :: "g" (lp)); #else - asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ + asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ #endif - asm("sw $4, 0($7)"); /* *lp = a0 */ + asm("sw $4, 0($7)"); /* *lp = a0 */ } static void extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, - unsigned int *rp) + unsigned int *rp) { - asm("sll $6, 1"); - asm("li $2, 31"); /* v0 holds number of shifts */ + asm("sll $6, 1"); + asm("li $2, 31"); /* v0 holds number of shifts */ asm("loop: - srl $15, $6, 31"); - asm("sll $5, 1"); - asm("or $5, $15"); - asm("sll $6, 1"); - asm("subu $15, $5, $4"); /* t = h - d */ - asm("bltz $15, underflow"); - asm("move $5, $15"); - asm("or $6, 1"); + srl $15, $6, 31"); + asm("sll $5, 1"); + asm("or $5, $15"); + asm("sll $6, 1"); + asm("subu $15, $5, $4"); /* t = h - d */ + asm("bltz $15, underflow"); + asm("move $5, $15"); + asm("or $6, 1"); asm("underflow: - subu $2, 1"); - asm("bnez $2, loop"); - asm("sw $6, 0($7)"); /* *qp = l */ + subu $2, 1"); + asm("bnez $2, loop"); + asm("sw $6, 0($7)"); /* *qp = l */ #ifdef __GNUC__ - asm("lw $7, %0" :: "g" (rp)); + asm("lw $7, %0" :: "g" (rp)); #else - asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ + asm("lw $7, 16($sp)"); /* fetch fifth actual argument from stack */ #endif - asm("sw $5, 0($7)"); /* *rp = h */ + asm("sw $5, 0($7)"); /* *rp = h */ } #endif /* __mips */ @@ -347,35 +347,35 @@ extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, static void extended_mul(int d, int q, int r, int *hp, int *lp) { - asm(" - movl d2,a7@- - clrl d2 - movl a6@(8),d0 - mulul a6@(12),d1:d0 - addl a6@(16),d0 - addxl d2,d1 - lsll #1,d0 - roxll #1,d1 - lsrl #1,d0 - movl a6@(20),a0 - movl d1,a0@ - movl a6@(24),a0 - movl d0,a0@ - movl a7@+,d2 - "); + asm(" + movl d2,a7@- + clrl d2 + movl a6@(8),d0 + mulul a6@(12),d1:d0 + addl a6@(16),d0 + addxl d2,d1 + lsll #1,d0 + roxll #1,d1 + lsrl #1,d0 + movl a6@(20),a0 + movl d1,a0@ + movl a6@(24),a0 + movl d0,a0@ + movl a7@+,d2 + "); } static void extended_div(int d, int h, int l, int *qp, int *rp) { - asm("moveml a6@(12),#0x303 - lsll #1,d1 - lsrl #1,d0 - roxrl #1,d1 - divul a6@(8),d0:d1 - movl d0,a1@ - movl d1,a0@ - "); + asm("moveml a6@(12),#0x303 + lsll #1,d1 + lsrl #1,d0 + roxrl #1,d1 + divul a6@(8),d0:d1 + movl d0,a1@ + movl d1,a0@ + "); } #endif /* sun3 */ @@ -385,24 +385,24 @@ extended_div(int d, int h, int l, int *qp, int *rp) _extended_mul: !#PROLOGUE# 0 !#PROLOGUE# 1 - save %sp,-96,%sp - mov %i0,%o0 - call .umul,2 - mov %i1,%o1 - addcc %o0,%i2,%i0 - addx %o1,0,%o1 - sll %o1,1,%o1 - tst %i0 - bge L77003 - sethi %hi(0x7fffffff),%o3 - or %o3,%lo(0x7fffffff),%o3 ! [internal] - and %i0,%o3,%i0 - inc %o1 + save %sp,-96,%sp + mov %i0,%o0 + call .umul,2 + mov %i1,%o1 + addcc %o0,%i2,%i0 + addx %o1,0,%o1 + sll %o1,1,%o1 + tst %i0 + bge L77003 + sethi %hi(0x7fffffff),%o3 + or %o3,%lo(0x7fffffff),%o3 ! [internal] + and %i0,%o3,%i0 + inc %o1 L77003: - st %i0,[%i4] - st %o1,[%i3] - ret - restore %g0,0,%o0 + st %i0,[%i4] + st %o1,[%i3] + ret + restore %g0,0,%o0 #endif sparc */ @@ -413,25 +413,25 @@ L77003: static void extended_mul(unsigned int d, unsigned int q, unsigned int r, unsigned int *hp, - unsigned int *lp) + unsigned int *lp) { register unsigned short dlo = d & 0xffff, - dhi = d >> 16, - qlo = q & 0xffff, - qhi = q >> 16; + dhi = d >> 16, + qlo = q & 0xffff, + qhi = q >> 16; unsigned int d0 = dhi * qlo + dlo * qhi, - d1 = dhi * qhi, - d2 = dlo * qlo; + d1 = dhi * qhi, + d2 = dlo * qlo; - d1 = (d1 << 1) + (d0 >> 15); /* add 17 MSB of d0 */ - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ - d2 += (d0 & 0x7fff) << 16; /* add 15 LSB of d0: no overflow occurs */ - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ + d1 = (d1 << 1) + (d0 >> 15); /* add 17 MSB of d0 */ + d1 += d2 >> 31; /* add MSB of d2 */ + d2 &= 0x7fffffff; /* clear MSB of d2 */ + d2 += (d0 & 0x7fff) << 16; /* add 15 LSB of d0: no overflow occurs */ + d1 += d2 >> 31; /* add MSB of d2 */ + d2 &= 0x7fffffff; /* clear MSB of d2 */ d2 += r; - d1 += d2 >> 31; /* add MSB of d2 */ - d2 &= 0x7fffffff; /* clear MSB of d2 */ + d1 += d2 >> 31; /* add MSB of d2 */ + d2 &= 0x7fffffff; /* clear MSB of d2 */ *hp = d1; *lp = d2; @@ -439,7 +439,7 @@ extended_mul(unsigned int d, unsigned int q, unsigned int r, unsigned int *hp, static void extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, - unsigned int *rp) + unsigned int *rp) { int i; int borrow; @@ -456,7 +456,7 @@ extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, borrow = 1; if (i--) - h = (h << 1) | ((unsigned)l >> 31); + h = (h << 1) | ((unsigned)l >> 31); l = (l << 1) | borrow; @@ -475,20 +475,20 @@ extended_div(unsigned int d, unsigned int h, unsigned int l, unsigned int *qp, static void extended_mul(int d, int q, int r, int *hp, int *lp) { - asm(" emul 4(ap),8(ap),12(ap),r0"); - asm(" ashq $1,r0,r0"); - asm(" rotl $-1,r0,r0"); - asm(" movl r0,*20(ap)"); - asm(" movl r1,*16(ap)"); + asm(" emul 4(ap),8(ap),12(ap),r0"); + asm(" ashq $1,r0,r0"); + asm(" rotl $-1,r0,r0"); + asm(" movl r0,*20(ap)"); + asm(" movl r1,*16(ap)"); } static void extended_div(int d, int h, int l, int *qp, int *rp) { - asm(" clrl r0"); - asm(" movl 8(ap),r1"); - asm(" ashq $-1,r0,r0"); - asm(" addl2 12(ap),r0"); - asm(" ediv 4(ap),r0,*16(ap),*20(ap)"); + asm(" clrl r0"); + asm(" movl 8(ap),r1"); + asm(" ashq $-1,r0,r0"); + asm(" addl2 12(ap),r0"); + asm(" ediv 4(ap),r0,*16(ap),*20(ap)"); } #endif /* vax */ diff --git a/src/c/ecl_features.h b/src/c/ecl_features.h index 8d82a3cc9..3c3054ca2 100644 --- a/src/c/ecl_features.h +++ b/src/c/ecl_features.h @@ -27,64 +27,64 @@ ecl_def_string_array(feature_names,static,const) = { ecl_def_string_array_elt("COMMON-LISP"), ecl_def_string_array_elt("ANSI-CL"), #if defined(GBC_BOEHM) - ecl_def_string_array_elt("BOEHM-GC"), + ecl_def_string_array_elt("BOEHM-GC"), #endif #ifdef ECL_THREADS - ecl_def_string_array_elt("THREADS"), + ecl_def_string_array_elt("THREADS"), #endif #ifdef CLOS - ecl_def_string_array_elt("CLOS"), + ecl_def_string_array_elt("CLOS"), #endif #ifdef ENABLE_DLOPEN - ecl_def_string_array_elt("DLOPEN"), + ecl_def_string_array_elt("DLOPEN"), #endif #ifdef ECL_OLD_LOOP - ecl_def_string_array_elt("OLD-LOOP"), + ecl_def_string_array_elt("OLD-LOOP"), #endif - ecl_def_string_array_elt("ECL-PDE"), + ecl_def_string_array_elt("ECL-PDE"), #if defined(unix) || defined(netbsd) || defined(openbsd) || defined(linux) || defined(darwin) || \ - defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) - ecl_def_string_array_elt("UNIX"), + defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk) + ecl_def_string_array_elt("UNIX"), #endif #ifdef BSD - ecl_def_string_array_elt("BSD"), + ecl_def_string_array_elt("BSD"), #endif #ifdef SYSV - ecl_def_string_array_elt("SYSTEM-V"), + ecl_def_string_array_elt("SYSTEM-V"), #endif #ifdef MSDOS - ecl_def_string_array_elt("MS-DOS"), + ecl_def_string_array_elt("MS-DOS"), #endif #if defined(__MINGW32__) - ecl_def_string_array_elt("MINGW32"), + ecl_def_string_array_elt("MINGW32"), ecl_def_string_array_elt("WIN32"), #endif #if defined(__WIN64__) ecl_def_string_array_elt("WIN64"), #endif #ifdef _MSC_VER - ecl_def_string_array_elt("MSVC"), + ecl_def_string_array_elt("MSVC"), #endif #if defined(ECL_MS_WINDOWS_HOST) ecl_def_string_array_elt("WINDOWS"), #endif #ifdef ECL_CMU_FORMAT - ecl_def_string_array_elt("CMU-FORMAT"), + ecl_def_string_array_elt("CMU-FORMAT"), #endif #ifdef ECL_CLOS_STREAMS - ecl_def_string_array_elt("CLOS-STREAMS"), + ecl_def_string_array_elt("CLOS-STREAMS"), #endif #if defined(ECL_DYNAMIC_FFI) || defined(HAVE_LIBFFI) - ecl_def_string_array_elt("DFFI"), + ecl_def_string_array_elt("DFFI"), #endif #ifdef ECL_UNICODE - ecl_def_string_array_elt("UNICODE"), + ecl_def_string_array_elt("UNICODE"), #endif #ifdef ECL_LONG_FLOAT - ecl_def_string_array_elt("LONG-FLOAT"), + ecl_def_string_array_elt("LONG-FLOAT"), #endif #ifdef ECL_RELATIVE_PACKAGE_NAMES - ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), + ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"), #endif #ifdef ecl_uint16_t ecl_def_string_array_elt("UINT16-T"), @@ -105,21 +105,21 @@ ecl_def_string_array(feature_names,static,const) = { ecl_def_string_array_elt("C++"), #endif #ifdef ECL_SSE2 - ecl_def_string_array_elt("SSE2"), + ecl_def_string_array_elt("SSE2"), #endif #ifdef ECL_SEMAPHORES - ecl_def_string_array_elt("SEMAPHORES"), + ecl_def_string_array_elt("SEMAPHORES"), #endif #ifdef ECL_RWLOCK - ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), + ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"), #endif #ifdef WORDS_BIGENDIAN - ecl_def_string_array_elt("BIG-ENDIAN"), + ecl_def_string_array_elt("BIG-ENDIAN"), #else - ecl_def_string_array_elt("LITTLE-ENDIAN"), + ecl_def_string_array_elt("LITTLE-ENDIAN"), #endif #ifdef ECL_WEAK_HASH - ecl_def_string_array_elt("ECL-WEAK-HASH"), + ecl_def_string_array_elt("ECL-WEAK-HASH"), #endif ecl_def_string_array_elt(0) }; diff --git a/src/c/error.d b/src/c/error.d index 4847ebbdd..c6fc20fb9 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -51,29 +51,29 @@ void ecl_internal_error(const char *s) { int saved_errno = errno; - fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); + fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); if (saved_errno) { fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); } - fflush(stderr); + fflush(stderr); si_dump_c_backtrace(ecl_make_fixnum(32)); #ifdef SIGIOT - signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ + signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ #endif - abort(); + abort(); } void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) { - /* - * Right now we have no means of specifying a jump point - * for really bad events. We just jump to the outermost - * frame, which is equivalent to quitting, and wait for - * someone to intercept this jump. - */ + /* + * Right now we have no means of specifying a jump point + * for really bad events. We just jump to the outermost + * frame, which is equivalent to quitting, and wait for + * someone to intercept this jump. + */ ecl_frame_ptr destination; cl_object tag; @@ -91,41 +91,41 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_unwind(the_env, destination); } } - if (the_env->frs_org <= the_env->frs_top) { - destination = ecl_process_env()->frs_org; - ecl_unwind(the_env, destination); - } else { - ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); - } + if (the_env->frs_org <= the_env->frs_top) { + destination = ecl_process_env()->frs_org; + ecl_unwind(the_env, destination); + } else { + ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); + } } /*****************************************************************************/ -/* Support for Lisp Error Handler */ +/* Support for Lisp Error Handler */ /*****************************************************************************/ void FEerror(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* condition text */ - cl_grab_rest_args(args)); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* condition text */ + cl_grab_rest_args(args)); _ecl_unexpected_return(); } cl_object CEerror(cl_object c, const char *err, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', - c, /* correctable */ - make_constant_base_string(err), /* continue-format-string */ - cl_grab_rest_args(args)); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', + c, /* correctable */ + make_constant_base_string(err), /* continue-format-string */ + cl_grab_rest_args(args)); } /*********************** @@ -135,63 +135,63 @@ CEerror(cl_object c, const char *err, int narg, ...) void FEprogram_error(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); } void FEprogram_error_noreturn(const char *s, int narg, ...) { - cl_object real_args, text; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - text = make_constant_base_string(s); - real_args = cl_grab_rest_args(args); - if (cl_boundp(@'si::*current-form*') != ECL_NIL) { - /* When FEprogram_error is invoked from the compiler, we can - * provide information about the offending form. - */ - cl_object stmt = ecl_symbol_value(@'si::*current-form*'); - if (stmt != ECL_NIL) { - real_args = @list(3, stmt, text, real_args); - text = make_constant_base_string("In form~%~S~%~?"); - } - } - si_signal_simple_error(4, - @'program-error', /* condition name */ - ECL_NIL, /* not correctable */ - text, - real_args); + cl_object real_args, text; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + text = make_constant_base_string(s); + real_args = cl_grab_rest_args(args); + if (cl_boundp(@'si::*current-form*') != ECL_NIL) { + /* When FEprogram_error is invoked from the compiler, we can + * provide information about the offending form. + */ + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); + if (stmt != ECL_NIL) { + real_args = @list(3, stmt, text, real_args); + text = make_constant_base_string("In form~%~S~%~?"); + } + } + si_signal_simple_error(4, + @'program-error', /* condition name */ + ECL_NIL, /* not correctable */ + text, + real_args); } void FEcontrol_error(const char *s, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(4, - @'control-error', /* condition name */ - ECL_NIL, /* not correctable */ - make_constant_base_string(s), /* format control */ - cl_grab_rest_args(args)); /* format args */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(4, + @'control-error', /* condition name */ + ECL_NIL, /* not correctable */ + make_constant_base_string(s), /* format control */ + cl_grab_rest_args(args)); /* format args */ } void @@ -199,8 +199,8 @@ FEreader_error(const char *s, cl_object stream, int narg, ...) { cl_object message = make_constant_base_string(s); cl_object args_list; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); args_list = cl_grab_rest_args(args); if (Null(stream)) { /* Parser error */ @@ -229,25 +229,25 @@ FEreader_error(const char *s, cl_object stream, int narg, ...) void FEcannot_open(cl_object fn) { - cl_error(3, @'file-error', @':pathname', fn); + cl_error(3, @'file-error', @':pathname', fn); } void FEend_of_file(cl_object strm) { - cl_error(3, @'end-of-file', @':stream', strm); + cl_error(3, @'end-of-file', @':stream', strm); } void FEclosed_stream(cl_object strm) { - cl_error(3, @'stream-error', @':stream', strm); + cl_error(3, @'stream-error', @':stream', strm); } cl_object si_signal_type_error(cl_object value, cl_object type) { - return cl_error(5, @'type-error', @':expected-type', type, + return cl_error(5, @'type-error', @':expected-type', type, @':datum', value); } @@ -341,7 +341,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, "the ~:R index into the object~% ~A~%" "takes a value ~D out of the range ~A."; cl_object limit = ecl_make_integer(nonincl_limit-1); - cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); + cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit); cl_object message = make_constant_base_string((which<0) ? message1 : message2); cl_env_ptr env = ecl_process_env(); struct ecl_ihs_frame tmp_ihs; @@ -361,19 +361,19 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, void FEunbound_variable(cl_object sym) { - cl_error(3, @'unbound-variable', @':name', sym); + cl_error(3, @'unbound-variable', @':name', sym); } void FEundefined_function(cl_object fname) { - cl_error(3, @'undefined-function', @':name', fname); + cl_error(3, @'undefined-function', @':name', fname); } void FEprint_not_readable(cl_object x) { - cl_error(3, @'print-not-readable', @':object', x); + cl_error(3, @'print-not-readable', @':object', x); } /************* @@ -384,48 +384,48 @@ void FEwrong_num_arguments(cl_object fun) { fun = cl_symbol_or_object(fun); - FEprogram_error("Wrong number of arguments passed to function ~S.", - 1, fun); + FEprogram_error("Wrong number of arguments passed to function ~S.", + 1, fun); } void FEwrong_num_arguments_anonym(void) { - FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); + FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); } void FEinvalid_macro_call(cl_object name) { - FEerror("Invalid macro call to ~S.", 1, name); + FEerror("Invalid macro call to ~S.", 1, name); } void FEinvalid_variable(const char *s, cl_object obj) { - FEerror(s, 1, obj); + FEerror(s, 1, obj); } void FEassignment_to_constant(cl_object v) { - FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); + FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v); } void FEinvalid_function(cl_object obj) { - FEwrong_type_argument(@'function', obj); + FEwrong_type_argument(@'function', obj); } void FEinvalid_function_name(cl_object fname) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid function name ~D"), - @':format-arguments', cl_list(1, fname), - @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), - @':datum', fname); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid function name ~D"), + @':format-arguments', cl_list(1, fname), + @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'), + @':datum', fname); } /* bootstrap version */ @@ -456,21 +456,21 @@ universal_error_handler(cl_object continue_string, cl_object datum, ecl_bds_unwind_n(the_env, 5); } ABORT: - ecl_internal_error("\nLisp initialization error.\n"); + ecl_internal_error("\nLisp initialization error.\n"); } void FEdivision_by_zero(cl_object x, cl_object y) { - cl_error(5, @'division-by-zero', @':operation', @'/', - @':operands', cl_list(2, x, y)); + cl_error(5, @'division-by-zero', @':operation', @'/', + @':operands', cl_list(2, x, y)); } cl_object _ecl_strerror(int code) { - const char *error = strerror(code); - return make_base_string_copy(error); + const char *error = strerror(code); + return make_base_string_copy(error); } /************************************* @@ -484,15 +484,15 @@ _ecl_strerror(int code) void FElibc_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - FEerror("~?~%C library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - error); + FEerror("~?~%C library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + error); } #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) @@ -501,23 +501,23 @@ ecl_def_ct_base_string(unknown_error,"[Unable to get error message]",28,static,c void FEwin32_error(const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, win_msg_obj; - char *win_msg; + ecl_va_list args; + cl_object rest, win_msg_obj; + char *win_msg; - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) - win_msg_obj = unknown_error; - else { - win_msg_obj = make_base_string_copy(win_msg); - LocalFree(win_msg); - } + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0) + win_msg_obj = unknown_error; + else { + win_msg_obj = make_base_string_copy(win_msg); + LocalFree(win_msg); + } - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); - FEerror("~?~%Windows library explanation: ~A.", 3, - make_constant_base_string(msg), rest, - win_msg_obj); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); + FEerror("~?~%Windows library explanation: ~A.", 3, + make_constant_base_string(msg), rest, + win_msg_obj); } #endif @@ -527,24 +527,24 @@ FEwin32_error(const char *msg, int narg, ...) @(defun error (eformat &rest args) @ - ecl_enable_interrupts(); - funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, + ecl_enable_interrupts(); + funcall(4, @'si::universal-error-handler', ECL_NIL, eformat, cl_grab_rest_args(args)); - _ecl_unexpected_return(); - @(return); + _ecl_unexpected_return(); + @(return); @) @(defun cerror (cformat eformat &rest args) @ - ecl_enable_interrupts(); - return funcall(4, @'si::universal-error-handler', cformat, eformat, - cl_grab_rest_args(args)); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', cformat, eformat, + cl_grab_rest_args(args)); @) void init_error(void) { - ecl_def_c_function(@'si::universal-error-handler', + ecl_def_c_function(@'si::universal-error-handler', (cl_objectfn_fixed)universal_error_handler, 3); } diff --git a/src/c/eval.d b/src/c/eval.d index 223c052fb..03fdcd4b4 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -23,14 +23,14 @@ cl_object * _ecl_va_sp(cl_narg narg) { - return ecl_process_env()->stack_top - narg; + return ecl_process_env()->stack_top - narg; } /* Calling conventions: Compiled C code calls lisp function supplying #args, and args. Linking function performs check_args, gets jmp_buf with _setjmp, then if cfun then stores C code address into function link location - and transfers to jmp_buf at cf_self + and transfers to jmp_buf at cf_self if cclosure then replaces #args with cc_env and calls cc_self otherwise, it emulates funcall. */ @@ -38,88 +38,88 @@ _ecl_va_sp(cl_narg narg) cl_object ecl_apply_from_stack_frame(cl_object frame, cl_object x) { - cl_object *sp = frame->frame.base; - cl_index narg = frame->frame.size; - cl_object fun = x; + cl_object *sp = frame->frame.base; + cl_index narg = frame->frame.size; + cl_object fun = x; AGAIN: frame->frame.env->function = fun; - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - case t_cfun: - return APPLY(narg, fun->cfun.entry, sp); - case t_cclosure: - return APPLY(narg, fun->cclosure.entry, sp); + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) + FEwrong_num_arguments(fun); + return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); + case t_cfun: + return APPLY(narg, fun->cfun.entry, sp); + case t_cclosure: + return APPLY(narg, fun->cclosure.entry, sp); #ifdef CLOS - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - return _ecl_standard_dispatch(frame, fun); - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; + case t_instance: + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + return _ecl_standard_dispatch(frame, fun); + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - return APPLY(narg, fun->instance.entry, sp); - default: - FEinvalid_function(fun); - } + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + return APPLY(narg, fun->instance.entry, sp); + default: + FEinvalid_function(fun); + } #endif - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - return ecl_interpret(frame, ECL_NIL, fun); - case t_bclosure: - return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - default: - FEinvalid_function(x); - } + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + return ecl_interpret(frame, ECL_NIL, fun); + case t_bclosure: + return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); + default: + FEinvalid_function(x); + } } cl_objectfn ecl_function_dispatch(cl_env_ptr env, cl_object x) { - cl_object fun = x; + cl_object fun = x; AGAIN: - if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; + if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; #ifdef CLOS - case t_instance: + case t_instance: env->function = fun; return fun->instance.entry; #endif - case t_symbol: - if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - env->function = fun; + case t_symbol: + if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + env->function = fun; return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; + case t_bclosure: + env->function = fun; return fun->bclosure.entry; - default: - FEinvalid_function(x); - } + default: + FEinvalid_function(x); + } } cl_object @@ -137,124 +137,124 @@ cl_funcall(cl_narg narg, cl_object function, ...) @(defun apply (fun lastarg &rest args) @ - if (narg == 2 && ecl_t_of(lastarg) == t_frame) { - return ecl_apply_from_stack_frame(lastarg, fun); - } else { - cl_object out; - cl_index i; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(the_env, - (cl_object)&frame_aux, - narg -= 2); - for (i = 0; i < narg; i++) { - ECL_STACK_FRAME_SET(frame, i, lastarg); - lastarg = ecl_va_arg(args); - } - if (ecl_t_of(lastarg) == t_frame) { - /* This could be replaced with a memcpy() */ + if (narg == 2 && ecl_t_of(lastarg) == t_frame) { + return ecl_apply_from_stack_frame(lastarg, fun); + } else { + cl_object out; + cl_index i; + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(the_env, + (cl_object)&frame_aux, + narg -= 2); + for (i = 0; i < narg; i++) { + ECL_STACK_FRAME_SET(frame, i, lastarg); + lastarg = ecl_va_arg(args); + } + if (ecl_t_of(lastarg) == t_frame) { + /* This could be replaced with a memcpy() */ for (i = 0; i < lastarg->frame.size; i++) { - ecl_stack_frame_push(frame, lastarg->frame.base[i]); - } - } else loop_for_in (lastarg) { + ecl_stack_frame_push(frame, lastarg->frame.base[i]); + } + } else loop_for_in (lastarg) { if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) { - ecl_stack_frame_close(frame); - FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); - } - ecl_stack_frame_push(frame, CAR(lastarg)); - i++; - } end_loop_for_in; - out = ecl_apply_from_stack_frame(frame, fun); - ecl_stack_frame_close(frame); - return out; - } + ecl_stack_frame_close(frame); + FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0); + } + ecl_stack_frame_push(frame, CAR(lastarg)); + i++; + } end_loop_for_in; + out = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + return out; + } @) cl_object cl_eval(cl_object form) { - return si_eval_with_env(1, form); + return si_eval_with_env(1, form); } @(defun constantp (arg &optional env) @ - return _ecl_funcall3(@'ext::constantp-inner', arg, env); + return _ecl_funcall3(@'ext::constantp-inner', arg, env); @) @(defun ext::constantp-inner (form &optional env) - cl_object value; + cl_object value; @ AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_T; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - value = ECL_T; - break; - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - value = ECL_NIL; - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - if (!(form->symbol.stype & ecl_stp_constant)) { - value = ECL_NIL; - break; - } - default: - value = ECL_T; - } - ecl_return1(the_env, value); + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_T; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + value = ECL_T; + break; + } + /* + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + */ + value = ECL_NIL; + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + if (!(form->symbol.stype & ecl_stp_constant)) { + value = ECL_NIL; + break; + } + default: + value = ECL_T; + } + ecl_return1(the_env, value); @) @(defun ext::constant-form-value (form &optional env) - cl_object value; + cl_object value; @ { AGAIN: - switch (ecl_t_of(form)) { - case t_list: - if (Null(form)) { - value = ECL_NIL; - break; - } - if (ECL_CONS_CAR(form) == @'quote') { - return cl_second(form); - } - /* - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - */ - ERROR: - FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", - 0, form); - break; - case t_symbol: - value = cl_macroexpand(2, form, env); - if (value != form) { - form = value; - goto AGAIN; - } - value = ECL_SYM_VAL(the_env, value); - break; - default: - value = form; - } - @(return value); + switch (ecl_t_of(form)) { + case t_list: + if (Null(form)) { + value = ECL_NIL; + break; + } + if (ECL_CONS_CAR(form) == @'quote') { + return cl_second(form); + } + /* + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + */ + ERROR: + FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A", + 0, form); + break; + case t_symbol: + value = cl_macroexpand(2, form, env); + if (value != form) { + form = value; + goto AGAIN; + } + value = ECL_SYM_VAL(the_env, value); + break; + default: + value = form; + } + @(return value); } @) diff --git a/src/c/ffi.d b/src/c/ffi.d index ae33ffb23..413a1323f 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -19,10 +19,10 @@ #include static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { - @':void', /* ecl_aet_object */ - @':float', /* ecl_aet_df */ - @':double', /* ecl_aet_df */ - @':void', /* ecl_aet_bit */ + @':void', /* ecl_aet_object */ + @':float', /* ecl_aet_df */ + @':double', /* ecl_aet_df */ + @':void', /* ecl_aet_bit */ #if ECL_FIXNUM_BITS == 32 && defined(ecl_uint32_t) @':int32-t', /* ecl_aet_fix */ @':uint32-t', /* ecl_aet_index */ @@ -35,7 +35,7 @@ static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { @':void', /* ecl_aet_index */ # endif #endif - @':uint8-t', /* ecl_aet_b8 */ + @':uint8-t', /* ecl_aet_b8 */ @':int8-t', /* ecl_aet_i8 */ #ifdef ecl_uint16_t @':uint16-t', /* ecl_aet_b16 */ @@ -51,50 +51,50 @@ static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { #endif #ifdef ECL_UNICODE # ifdef ecl_int32_t - @':int32-t', /* ecl_aet_ch */ + @':int32-t', /* ecl_aet_ch */ # else @':void', /* ecl_aet_ch */ # endif #endif - @':char' /* ecl_aet_bc */ + @':char' /* ecl_aet_bc */ }; #define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) #ifdef __GNUC__ typedef struct { - cl_object name; - cl_index size; - cl_index alignment; + cl_object name; + cl_index size; + cl_index alignment; } ecl_foreign_type_record; # define ALIGNMENT(tag) (ecl_foreign_type_table[tag].alignment) -# define FFI_DESC(symbol,type) \ +# define FFI_DESC(symbol,type) \ {symbol, sizeof(type), (AUX_PTR(type)->b.d - AUX_PTR(type)->a)} #else typedef struct { - cl_object name; - cl_index size; - char *d, *a; + cl_object name; + cl_index size; + char *d, *a; } ecl_foreign_type_record; #define ALIGNMENT(tag) (ecl_foreign_type_table[tag].d - ecl_foreign_type_table[tag].a) #define AUX_PTR(type) \ - ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) + ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0) #define FFI_DESC(symbol,type) \ {symbol, sizeof(type), AUX_PTR(type)->b.d, AUX_PTR(type)->a} #endif static const ecl_foreign_type_record ecl_foreign_type_table[] = { - FFI_DESC(@':char', char), - FFI_DESC(@':unsigned-char', unsigned char), - FFI_DESC(@':byte', ecl_int8_t), + FFI_DESC(@':char', char), + FFI_DESC(@':unsigned-char', unsigned char), + FFI_DESC(@':byte', ecl_int8_t), FFI_DESC(@':unsigned-byte', ecl_uint8_t), - FFI_DESC(@':short', short), - FFI_DESC(@':unsigned-short', unsigned short), - FFI_DESC(@':int', int), - FFI_DESC(@':unsigned-int', unsigned int), - FFI_DESC(@':long', long), - FFI_DESC(@':unsigned-long', unsigned long), + FFI_DESC(@':short', short), + FFI_DESC(@':unsigned-short', unsigned short), + FFI_DESC(@':int', int), + FFI_DESC(@':unsigned-int', unsigned int), + FFI_DESC(@':long', long), + FFI_DESC(@':unsigned-long', unsigned long), #ifdef ecl_uint8_t FFI_DESC(@':int8-t', ecl_int8_t), FFI_DESC(@':uint8-t', ecl_uint8_t), @@ -115,18 +115,18 @@ ecl_foreign_type_table[] = { FFI_DESC(@':long-long', long long), FFI_DESC(@':unsigned-long-long', unsigned long long), #endif - FFI_DESC(@':pointer-void', void *), - FFI_DESC(@':cstring', char *), - FFI_DESC(@':object', cl_object), - FFI_DESC(@':float', float), - FFI_DESC(@':double', double), - {@':void', 0, 0} + FFI_DESC(@':pointer-void', void *), + FFI_DESC(@':cstring', char *), + FFI_DESC(@':object', cl_object), + FFI_DESC(@':float', float), + FFI_DESC(@':double', double), + {@':void', 0, 0} }; #ifdef ECL_DYNAMIC_FFI static const cl_object ecl_foreign_cc_table[] = { - @':cdecl', - @':stdcall' + @':cdecl', + @':stdcall' }; #endif @@ -137,29 +137,29 @@ static struct { } ecl_foreign_cc_table[] = { {@':default', FFI_DEFAULT_ABI}, #ifdef X86_WIN32 - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':stdcall', FFI_STDCALL}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':stdcall', FFI_STDCALL}, #elif defined(X86_WIN64) - {@':win64', FFI_WIN64}, + {@':win64', FFI_WIN64}, #elif defined(X86_ANY) || defined(X86) || defined(X86_64) - {@':cdecl', FFI_SYSV}, - {@':sysv', FFI_SYSV}, - {@':unix64', FFI_UNIX64}, + {@':cdecl', FFI_SYSV}, + {@':sysv', FFI_SYSV}, + {@':unix64', FFI_UNIX64}, #endif }; static ffi_type *ecl_type_to_libffi_type[] = { - &ffi_type_schar, /*@':char',*/ - &ffi_type_uchar, /*@':unsigned-char',*/ - &ffi_type_sint8, /*@':byte',*/ - &ffi_type_uint8, /*@':unsigned-byte',*/ - &ffi_type_sshort, /*@':short',*/ - &ffi_type_ushort, /*@':unsigned-short',*/ - &ffi_type_sint, /*@':int',*/ - &ffi_type_uint, /*@':unsigned-int',*/ - &ffi_type_slong, /*@':long',*/ - &ffi_type_ulong, /*@':unsigned-long',*/ + &ffi_type_schar, /*@':char',*/ + &ffi_type_uchar, /*@':unsigned-char',*/ + &ffi_type_sint8, /*@':byte',*/ + &ffi_type_uint8, /*@':unsigned-byte',*/ + &ffi_type_sshort, /*@':short',*/ + &ffi_type_ushort, /*@':unsigned-short',*/ + &ffi_type_sint, /*@':int',*/ + &ffi_type_uint, /*@':unsigned-int',*/ + &ffi_type_slong, /*@':long',*/ + &ffi_type_ulong, /*@':unsigned-long',*/ #ifdef ecl_uint8_t &ffi_type_sint8, /*@':int8-t',*/ &ffi_type_uint8, /*@':uint8-t',*/ @@ -180,117 +180,117 @@ static ffi_type *ecl_type_to_libffi_type[] = { &ffi_type_sint64, /*@':long-long',*/ /*FIXME! libffi does not have long long */ &ffi_type_uint64, /*@':unsigned-long-long',*/ #endif - &ffi_type_pointer, /*@':pointer-void',*/ - &ffi_type_pointer, /*@':cstring',*/ - &ffi_type_pointer, /*@':object',*/ - &ffi_type_float, /*@':float',*/ - &ffi_type_double, /*@':double',*/ - &ffi_type_void /*@':void'*/ + &ffi_type_pointer, /*@':pointer-void',*/ + &ffi_type_pointer, /*@':cstring',*/ + &ffi_type_pointer, /*@':object',*/ + &ffi_type_float, /*@':float',*/ + &ffi_type_double, /*@':double',*/ + &ffi_type_void /*@':void'*/ }; #endif /* HAVE_LIBFFI */ cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag == ECL_NIL ? @':void' : tag; - output->foreign.size = size; - output->foreign.data = (char*)data; - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag == ECL_NIL ? @':void' : tag; + output->foreign.size = size; + output->foreign.data = (char*)data; + return output; } cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size) { - cl_object output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = (char*)ecl_alloc_atomic(size); - return output; + cl_object output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = (char*)ecl_alloc_atomic(size); + return output; } void * ecl_foreign_data_pointer_safe(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_only_arg(@[si::foreign-data-pointer], f, @[si::foreign-data]); } - return f->foreign.data; + return f->foreign.data; } char * ecl_base_string_pointer_safe(cl_object f) { - unsigned char *s; - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - s = f->base_string.self; - if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && + unsigned char *s; + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + s = f->base_string.self; + if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) && s[f->base_string.fillp] != 0)) { - FEerror("Cannot coerce a string with fill pointer to (char *)", 0); - } - return (char *)s; + FEerror("Cannot coerce a string with fill pointer to (char *)", 0); + } + return (char *)s; } cl_object ecl_null_terminated_base_string(cl_object f) { - /* FIXME! Is there a better function name? */ - f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); - if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && + /* FIXME! Is there a better function name? */ + f = ecl_check_cl_type(@'si::make-foreign-data-from-array', f, t_base_string); + if (ECL_ARRAY_HAS_FILL_POINTER_P(f) && f->base_string.self[f->base_string.fillp] != 0) { - return cl_copy_seq(f); - } else { - return f; - } + return cl_copy_seq(f); + } else { + return f; + } } cl_object si_allocate_foreign_data(cl_object tag, cl_object size) { - cl_object output = ecl_alloc_object(t_foreign); - cl_index bytes = ecl_to_size(size); - output->foreign.tag = tag; - output->foreign.size = bytes; - /* FIXME! Should be atomic uncollectable or malloc, but we do not export - * that garbage collector interface and malloc may be overwritten - * by the GC library */ - output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; - @(return output) + cl_object output = ecl_alloc_object(t_foreign); + cl_index bytes = ecl_to_size(size); + output->foreign.tag = tag; + output->foreign.size = bytes; + /* FIXME! Should be atomic uncollectable or malloc, but we do not export + * that garbage collector interface and malloc may be overwritten + * by the GC library */ + output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL; + @(return output) } cl_object si_free_foreign_data(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_only_arg(@[si::free-foreign-data], f, @[si::foreign-data]); - } - if (f->foreign.size) { - /* See si_allocate_foreign_data() */ - ecl_free_uncollectable(f->foreign.data); - } - f->foreign.size = 0; - f->foreign.data = NULL; + } + if (f->foreign.size) { + /* See si_allocate_foreign_data() */ + ecl_free_uncollectable(f->foreign.data); + } + f->foreign.size = 0; + f->foreign.data = NULL; @(return) } cl_object si_make_foreign_data_from_array(cl_object array) { - cl_object tag; - if (ecl_unlikely(ecl_t_of(array) != t_array && ecl_t_of(array) != t_vector)) { + cl_object tag; + if (ecl_unlikely(ecl_t_of(array) != t_array && ecl_t_of(array) != t_vector)) { FEwrong_type_only_arg(@[si::make-foreign-data-from-array], array, @[array]); - } + } tag = ecl_aet_to_ffi_table[array->array.elttype]; if (ecl_unlikely(Null(tag))) { - FEerror("Cannot make foreign object from array " + FEerror("Cannot make foreign object from array " "with element type ~S.", 1, ecl_elttype_to_symbol(array->array.elttype)); - } - @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); + } + @(return ecl_make_foreign_data(tag, 0, array->array.self.bc)); } cl_object @@ -302,133 +302,133 @@ si_foreign_data_p(cl_object f) cl_object si_foreign_data_address(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_only_arg(@[si::foreign-data-address], f, @[si::foreign-data]); - } - @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)) + } + @(return ecl_make_unsigned_integer((cl_index)f->foreign.data)) } cl_object si_foreign_data_tag(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_only_arg(@[si::foreign-data-tag], f, @[si::foreign-data]); - } - @(return f->foreign.tag); + } + @(return f->foreign.tag); } cl_object si_foreign_data_equal(cl_object f1, cl_object f2) { - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { FEwrong_type_only_arg(@[si::foreign-data-address], f1, @[si::foreign-data]); - } - if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { + } + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { FEwrong_type_only_arg(@[si::foreign-data-address], f2, @[si::foreign-data]); - } - @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)) + } + @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL)) } cl_object si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize, - cl_object tag) + cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_only_arg(@[si::foreign-data-pointer], f, @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_alloc_object(t_foreign); - output->foreign.tag = tag; - output->foreign.size = size; - output->foreign.data = f->foreign.data + ndx; - @(return output) + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_alloc_object(t_foreign); + output->foreign.tag = tag; + output->foreign.size = size; + output->foreign.data = f->foreign.data + ndx; + @(return output) } cl_object si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag) { - cl_index ndx = ecl_to_size(andx); - cl_index size = ecl_to_size(asize); - cl_object output; + cl_index ndx = ecl_to_size(andx); + cl_index size = ecl_to_size(asize); + cl_object output; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f, @[si::foreign-data]); - } - if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - output = ecl_allocate_foreign_data(tag, size); - memcpy(output->foreign.data, f->foreign.data + ndx, size); - @(return output) + } + if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + output = ecl_allocate_foreign_data(tag, size); + memcpy(output->foreign.data, f->foreign.data + ndx, size); + @(return output) } cl_object si_foreign_data_set(cl_object f, cl_object andx, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index size, limit; + cl_index ndx = ecl_to_size(andx); + cl_index size, limit; - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f, @[si::foreign-data]); - } - if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { + } + if (ecl_unlikely(ecl_t_of(value) != t_foreign)) { FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value, @[si::foreign-data]); - } - size = value->foreign.size; - limit = f->foreign.size; - if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - memcpy(f->foreign.data + ndx, value->foreign.data, size); - @(return value) + } + size = value->foreign.size; + limit = f->foreign.size; + if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + memcpy(f->foreign.data + ndx, value->foreign.data, size); + @(return value) } static int foreign_type_code(cl_object type) { - int i; - for (i = 0; i <= ECL_FFI_VOID; i++) { - if (type == ecl_foreign_type_table[i].name) - return i; - } + int i; + for (i = 0; i <= ECL_FFI_VOID; i++) { + if (type == ecl_foreign_type_table[i].name) + return i; + } return -1; } enum ecl_ffi_tag ecl_foreign_type_code(cl_object type) { - int i = foreign_type_code(type); + int i = foreign_type_code(type); if (ecl_unlikely(i < 0)) { FEerror("~A does not denote an elementary foreign type.", 1, type); } - return (enum ecl_ffi_tag)i; + return (enum ecl_ffi_tag)i; } #ifdef HAVE_LIBFFI ffi_abi ecl_foreign_cc_code(cl_object cc) { - int i; - for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { - if (cc == ecl_foreign_cc_table[i].symbol) - return ecl_foreign_cc_table[i].abi; - } - FEerror("~A does no denote a valid calling convention.", 1, cc); - return ECL_FFI_CC_CDECL; + int i; + for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { + if (cc == ecl_foreign_cc_table[i].symbol) + return ecl_foreign_cc_table[i].abi; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; } #endif @@ -436,13 +436,13 @@ ecl_foreign_cc_code(cl_object cc) enum ecl_ffi_calling_convention ecl_foreign_cc_code(cl_object cc) { - int i; - for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { - if (cc == ecl_foreign_cc_table[i]) - return (enum ecl_ffi_calling_convention)i; - } - FEerror("~A does no denote a valid calling convention.", 1, cc); - return ECL_FFI_CC_CDECL; + int i; + for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) { + if (cc == ecl_foreign_cc_table[i]) + return (enum ecl_ffi_calling_convention)i; + } + FEerror("~A does no denote a valid calling convention.", 1, cc); + return ECL_FFI_CC_CDECL; } #endif @@ -451,31 +451,31 @@ static void wrong_ffi_tag(enum ecl_ffi_tag tag) ecl_attr_noreturn; static void wrong_ffi_tag(enum ecl_ffi_tag tag) { - FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); + FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag)); } cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) { - switch (tag) { - case ECL_FFI_CHAR: - return ECL_CODE_CHAR(*(char *)p); - case ECL_FFI_UNSIGNED_CHAR: - return ECL_CODE_CHAR(*(unsigned char *)p); - case ECL_FFI_BYTE: - return ecl_make_fixnum(*(int8_t *)p); - case ECL_FFI_UNSIGNED_BYTE: - return ecl_make_fixnum(*(uint8_t *)p); - case ECL_FFI_SHORT: - return ecl_make_fixnum(*(short *)p); - case ECL_FFI_UNSIGNED_SHORT: - return ecl_make_fixnum(*(unsigned short *)p); - case ECL_FFI_INT: - return ecl_make_integer(*(int *)p); - case ECL_FFI_UNSIGNED_INT: - return ecl_make_unsigned_integer(*(unsigned int *)p); - case ECL_FFI_LONG: - return ecl_make_integer(*(long *)p); + switch (tag) { + case ECL_FFI_CHAR: + return ECL_CODE_CHAR(*(char *)p); + case ECL_FFI_UNSIGNED_CHAR: + return ECL_CODE_CHAR(*(unsigned char *)p); + case ECL_FFI_BYTE: + return ecl_make_fixnum(*(int8_t *)p); + case ECL_FFI_UNSIGNED_BYTE: + return ecl_make_fixnum(*(uint8_t *)p); + case ECL_FFI_SHORT: + return ecl_make_fixnum(*(short *)p); + case ECL_FFI_UNSIGNED_SHORT: + return ecl_make_fixnum(*(unsigned short *)p); + case ECL_FFI_INT: + return ecl_make_integer(*(int *)p); + case ECL_FFI_UNSIGNED_INT: + return ecl_make_unsigned_integer(*(unsigned int *)p); + case ECL_FFI_LONG: + return ecl_make_integer(*(long *)p); #ifdef ecl_uint8_t case ECL_FFI_INT8_T: return ecl_make_fixnum(*(ecl_int8_t *)p); @@ -506,60 +506,60 @@ ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag) case ECL_FFI_UNSIGNED_LONG_LONG: return ecl_make_ulong_long(*(ecl_ulong_long_t *)p); #endif - case ECL_FFI_UNSIGNED_LONG: - return ecl_make_unsigned_integer(*(unsigned long *)p); - case ECL_FFI_POINTER_VOID: - return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); - case ECL_FFI_CSTRING: - return *(char **)p ? + case ECL_FFI_UNSIGNED_LONG: + return ecl_make_unsigned_integer(*(unsigned long *)p); + case ECL_FFI_POINTER_VOID: + return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p); + case ECL_FFI_CSTRING: + return *(char **)p ? ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL; - case ECL_FFI_OBJECT: - return *(cl_object *)p; - case ECL_FFI_FLOAT: - return ecl_make_single_float(*(float *)p); - case ECL_FFI_DOUBLE: - return ecl_make_double_float(*(double *)p); - case ECL_FFI_VOID: - return ECL_NIL; + case ECL_FFI_OBJECT: + return *(cl_object *)p; + case ECL_FFI_FLOAT: + return ecl_make_single_float(*(float *)p); + case ECL_FFI_DOUBLE: + return ecl_make_double_float(*(double *)p); + case ECL_FFI_VOID: + return ECL_NIL; default: wrong_ffi_tag(tag); - } + } } void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) { - switch (tag) { - case ECL_FFI_CHAR: - *(char *)p = (char)ecl_base_char_code(value); - break; - case ECL_FFI_UNSIGNED_CHAR: - *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); - break; - case ECL_FFI_BYTE: - *(int8_t *)p = ecl_to_int8_t(value); - break; - case ECL_FFI_UNSIGNED_BYTE: - *(uint8_t *)p = ecl_to_uint8_t(value); - break; - case ECL_FFI_SHORT: - *(short *)p = ecl_to_short(value); - break; - case ECL_FFI_UNSIGNED_SHORT: - *(unsigned short *)p = ecl_to_ushort(value); - break; - case ECL_FFI_INT: - *(int *)p = ecl_to_int(value); - break; - case ECL_FFI_UNSIGNED_INT: - *(unsigned int *)p = ecl_to_uint(value); - break; - case ECL_FFI_LONG: - *(long *)p = ecl_to_long(value); - break; - case ECL_FFI_UNSIGNED_LONG: - *(unsigned long *)p = ecl_to_ulong(value); - break; + switch (tag) { + case ECL_FFI_CHAR: + *(char *)p = (char)ecl_base_char_code(value); + break; + case ECL_FFI_UNSIGNED_CHAR: + *(unsigned char*)p = (unsigned char)ecl_base_char_code(value); + break; + case ECL_FFI_BYTE: + *(int8_t *)p = ecl_to_int8_t(value); + break; + case ECL_FFI_UNSIGNED_BYTE: + *(uint8_t *)p = ecl_to_uint8_t(value); + break; + case ECL_FFI_SHORT: + *(short *)p = ecl_to_short(value); + break; + case ECL_FFI_UNSIGNED_SHORT: + *(unsigned short *)p = ecl_to_ushort(value); + break; + case ECL_FFI_INT: + *(int *)p = ecl_to_int(value); + break; + case ECL_FFI_UNSIGNED_INT: + *(unsigned int *)p = ecl_to_uint(value); + break; + case ECL_FFI_LONG: + *(long *)p = ecl_to_long(value); + break; + case ECL_FFI_UNSIGNED_LONG: + *(unsigned long *)p = ecl_to_ulong(value); + break; case ECL_FFI_INT8_T: *(ecl_int8_t *)p = ecl_to_int8_t(value); break; @@ -598,129 +598,129 @@ ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value); break; #endif - case ECL_FFI_POINTER_VOID: - *(void **)p = ecl_foreign_data_pointer_safe(value); - break; - case ECL_FFI_CSTRING: - *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; - break; - case ECL_FFI_OBJECT: - *(cl_object *)p = value; - break; - case ECL_FFI_FLOAT: - *(float *)p = ecl_to_float(value); - break; - case ECL_FFI_DOUBLE: - *(double *)p = ecl_to_double(value); - break; - case ECL_FFI_VOID: - break; + case ECL_FFI_POINTER_VOID: + *(void **)p = ecl_foreign_data_pointer_safe(value); + break; + case ECL_FFI_CSTRING: + *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self; + break; + case ECL_FFI_OBJECT: + *(cl_object *)p = value; + break; + case ECL_FFI_FLOAT: + *(float *)p = ecl_to_float(value); + break; + case ECL_FFI_DOUBLE: + *(double *)p = ecl_to_double(value); + break; + case ECL_FFI_VOID: + break; default: wrong_ffi_tag(tag); - } + } } cl_object si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || (ndx + ecl_foreign_type_table[tag].size > limit))) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f, @[si::foreign-data]); - } - @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)) + } + @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag)) } cl_object si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value) { - cl_index ndx = ecl_to_size(andx); - cl_index limit = f->foreign.size; - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - if (ecl_unlikely(ndx >= limit || + cl_index ndx = ecl_to_size(andx); + cl_index limit = f->foreign.size; + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + if (ecl_unlikely(ndx >= limit || ndx + ecl_foreign_type_table[tag].size > limit)) { - FEerror("Out of bounds reference into foreign data type ~A.", 1, f); - } - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { + FEerror("Out of bounds reference into foreign data type ~A.", 1, f); + } + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) { FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f, @[si::foreign-data]); - } - ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); - @(return value) + } + ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value); + @(return value) } cl_object si_size_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size)) } cl_object si_alignment_of_foreign_elt_type(cl_object type) { - enum ecl_ffi_tag tag = ecl_foreign_type_code(type); - @(return ecl_make_fixnum(ALIGNMENT(tag))) + enum ecl_ffi_tag tag = ecl_foreign_type_code(type); + @(return ecl_make_fixnum(ALIGNMENT(tag))) } cl_object si_foreign_elt_type_p(cl_object type) { - @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)) + @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T)) } cl_object si_null_pointer_p(cl_object f) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) FEwrong_type_only_arg(@[si::null-pointer-p], f, @[si::foreign-data]); - @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)) + @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL)) } cl_object si_foreign_data_recast(cl_object f, cl_object size, cl_object tag) { - if (ecl_unlikely(ecl_t_of(f) != t_foreign)) + if (ecl_unlikely(ecl_t_of(f) != t_foreign)) FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f, @[si::foreign-data]); - f->foreign.size = ecl_to_size(size); - f->foreign.tag = tag; - @(return f) + f->foreign.size = ecl_to_size(size); + f->foreign.tag = tag; + @(return f) } cl_object si_load_foreign_module(cl_object filename) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); + FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0); #else - cl_object output; + cl_object output; # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { + mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif - output = ecl_library_open(filename, 0); - if (output->cblock.handle == NULL) { - cl_object aux = ecl_library_error(output); - ecl_library_close(output); - output = aux; - } + output = ecl_library_open(filename, 0); + if (output->cblock.handle == NULL) { + cl_object aux = ecl_library_error(output); + ecl_library_close(output); + output = aux; + } # ifdef ECL_THREADS - (void)0; /* MSVC complains about missing ';' before '}' */ - } ECL_UNWIND_PROTECT_EXIT { - mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); - } ECL_UNWIND_PROTECT_END; + (void)0; /* MSVC complains about missing ';' before '}' */ + } ECL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+')); + } ECL_UNWIND_PROTECT_END; # endif - if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { - FEerror("LOAD-FOREIGN-MODULE: Could not load " + if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) { + FEerror("LOAD-FOREIGN-MODULE: Could not load " "foreign module ~S (Error: ~S)", 2, filename, output); } output->cblock.locked |= 1; @@ -759,24 +759,24 @@ cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size) { #if !defined(ENABLE_DLOPEN) - FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); + FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0); #else - cl_object block; - cl_object output = ECL_NIL; - void *sym; + cl_object block; + cl_object output = ECL_NIL; + void *sym; - block = (module == @':default' ? module : si_load_foreign_module(module)); - var = ecl_null_terminated_base_string(var); - sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); - if (sym == NULL) { - if (block != @':default') - output = ecl_library_error(block); - goto OUTPUT; - } - output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); + block = (module == @':default' ? module : si_load_foreign_module(module)); + var = ecl_null_terminated_base_string(var); + sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); + if (sym == NULL) { + if (block != @':default') + output = ecl_library_error(block); + goto OUTPUT; + } + output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym); OUTPUT: - if (ecl_unlikely(ecl_t_of(output) != t_foreign)) - FEerror("FIND-FOREIGN-SYMBOL: Could not load " + if (ecl_unlikely(ecl_t_of(output) != t_foreign)) + FEerror("FIND-FOREIGN-SYMBOL: Could not load " "foreign symbol ~S from module ~S (Error: ~S)", 3, var, module, output); @(return output) @@ -787,100 +787,100 @@ OUTPUT: static void ecl_fficall_overflow() { - FEerror("Stack overflow on SI:CALL-CFUN", 0); + FEerror("Stack overflow on SI:CALL-CFUN", 0); } void ecl_fficall_prepare(cl_object return_type, cl_object arg_type, cl_object cc_type) { - struct ecl_fficall *fficall = cl_env.fficall; - fficall->buffer_sp = fficall->buffer; - fficall->buffer_size = 0; - fficall->cstring = ECL_NIL; - fficall->cc = ecl_foreign_cc_code(cc_type); + struct ecl_fficall *fficall = cl_env.fficall; + fficall->buffer_sp = fficall->buffer; + fficall->buffer_size = 0; + fficall->cstring = ECL_NIL; + fficall->cc = ecl_foreign_cc_code(cc_type); fficall->registers = ecl_fficall_prepare_extra(fficall->registers); } void ecl_fficall_push_bytes(void *data, size_t bytes) { - struct ecl_fficall *fficall = cl_env.fficall; - fficall->buffer_size += bytes; - if (fficall->buffer_size >= ECL_FFICALL_LIMIT) - ecl_fficall_overflow(); - memcpy(fficall->buffer_sp, (char*)data, bytes); - fficall->buffer_sp += bytes; + struct ecl_fficall *fficall = cl_env.fficall; + fficall->buffer_size += bytes; + if (fficall->buffer_size >= ECL_FFICALL_LIMIT) + ecl_fficall_overflow(); + memcpy(fficall->buffer_sp, (char*)data, bytes); + fficall->buffer_sp += bytes; } void ecl_fficall_push_int(int data) { - ecl_fficall_push_bytes(&data, sizeof(int)); + ecl_fficall_push_bytes(&data, sizeof(int)); } void ecl_fficall_align(int data) { - struct ecl_fficall *fficall = cl_env.fficall; - if (data == 1) - return; - else { - size_t sp = fficall->buffer_sp - fficall->buffer; - size_t mask = data - 1; - size_t new_sp = (sp + mask) & ~mask; - if (new_sp >= ECL_FFICALL_LIMIT) - ecl_fficall_overflow(); - fficall->buffer_sp = fficall->buffer + new_sp; - fficall->buffer_size = new_sp; - } + struct ecl_fficall *fficall = cl_env.fficall; + if (data == 1) + return; + else { + size_t sp = fficall->buffer_sp - fficall->buffer; + size_t mask = data - 1; + size_t new_sp = (sp + mask) & ~mask; + if (new_sp >= ECL_FFICALL_LIMIT) + ecl_fficall_overflow(); + fficall->buffer_sp = fficall->buffer + new_sp; + fficall->buffer_size = new_sp; + } } @(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl')) - struct ecl_fficall *fficall = cl_env.fficall; - void *cfun = ecl_foreign_data_pointer_safe(fun); - cl_object object; - enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type); + struct ecl_fficall *fficall = cl_env.fficall; + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; + enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type); @ - ecl_fficall_prepare(return_type, arg_types, cc_type); - while (CONSP(arg_types)) { - enum ecl_ffi_tag type; - if (!CONSP(args)) { - FEerror("In SI:CALL-CFUN, mismatch between argument types and argument list: ~A vs ~A", 0); - } - type = ecl_foreign_type_code(CAR(arg_types)); - if (type == ECL_FFI_CSTRING) { - object = ecl_null_terminated_base_string(CAR(args)); - if (CAR(args) != object) - fficall->cstring = - CONS(object, fficall->cstring); - } else { - object = CAR(args); - } - ecl_foreign_data_set_elt(&fficall->output, type, object); - ecl_fficall_push_arg(&fficall->output, type); - arg_types = CDR(arg_types); - args = CDR(args); - } - ecl_fficall_execute(cfun, fficall, return_type_tag); - object = ecl_foreign_data_ref_elt(&fficall->output, return_type_tag); + ecl_fficall_prepare(return_type, arg_types, cc_type); + while (CONSP(arg_types)) { + enum ecl_ffi_tag type; + if (!CONSP(args)) { + FEerror("In SI:CALL-CFUN, mismatch between argument types and argument list: ~A vs ~A", 0); + } + type = ecl_foreign_type_code(CAR(arg_types)); + if (type == ECL_FFI_CSTRING) { + object = ecl_null_terminated_base_string(CAR(args)); + if (CAR(args) != object) + fficall->cstring = + CONS(object, fficall->cstring); + } else { + object = CAR(args); + } + ecl_foreign_data_set_elt(&fficall->output, type, object); + ecl_fficall_push_arg(&fficall->output, type); + arg_types = CDR(arg_types); + args = CDR(args); + } + ecl_fficall_execute(cfun, fficall, return_type_tag); + object = ecl_foreign_data_ref_elt(&fficall->output, return_type_tag); - fficall->buffer_size = 0; - fficall->buffer_sp = fficall->buffer; - fficall->cstring = ECL_NIL; + fficall->buffer_size = 0; + fficall->buffer_sp = fficall->buffer; + fficall->cstring = ECL_NIL; - @(return object) + @(return object) @) @(defun si::make-dynamic-callback (fun sym rtype argtypes &optional (cctype @':cdecl')) - cl_object data; - cl_object cbk; + cl_object data; + cl_object cbk; @ - data = cl_list(3, fun, rtype, argtypes); - cbk = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype))); + data = cl_list(3, fun, rtype, argtypes); + cbk = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype))); - si_put_sysprop(sym, @':callback', CONS(cbk, data)); - @(return cbk) + si_put_sysprop(sym, @':callback', CONS(cbk, data)); + @(return cbk) @) #endif /* ECL_DYNAMIC_FFI */ @@ -929,7 +929,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, if (n >= the_env->ffi_args_limit) { resize_call_stack(the_env, n + 32); } - type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); + type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types)); arg_types = ECL_CONS_CDR(arg_types); the_env->ffi_types[++n] = ecl_type_to_libffi_type[type]; if (CONSP(args)) { @@ -965,19 +965,19 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, } @(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':default')) - void *cfun = ecl_foreign_data_pointer_safe(fun); - cl_object object; + void *cfun = ecl_foreign_data_pointer_safe(fun); + cl_object object; volatile cl_index sp; ffi_cif cif; @ { - sp = ECL_STACK_INDEX(the_env); - prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); + sp = ECL_STACK_INDEX(the_env); + prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); - object = ecl_foreign_data_ref_elt(the_env->ffi_values, + object = ecl_foreign_data_ref_elt(the_env->ffi_values, ecl_foreign_type_code(return_type)); - ECL_STACK_SET_INDEX(the_env, sp); - @(return object) + ECL_STACK_SET_INDEX(the_env, sp); + @(return object) } @) @@ -1009,7 +1009,7 @@ cl_object si_free_ffi_closure(cl_object closure) { ffi_closure_free(ecl_foreign_data_pointer_safe(closure)); - @(return); + @(return); } @(defun si::make-dynamic-callback (fun sym return_type arg_types @@ -1021,10 +1021,10 @@ si_free_ffi_closure(cl_object closure) int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type, &types); - /* libffi allocates executable memory for us. ffi_closure_alloc() - * returns a pointer to memory and a pointer to the beginning of - * the actual executable region (executable_closure) which is - * where the code resides. */ + /* libffi allocates executable memory for us. ffi_closure_alloc() + * returns a pointer to memory and a pointer to the beginning of + * the actual executable region (executable_closure) which is + * where the code resides. */ void *executable_region; ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region); @@ -1047,7 +1047,7 @@ si_free_ffi_closure(cl_object closure) FEerror("Unable to build callback. libffi returns ~D", 1, ecl_make_fixnum(status)); } - si_put_sysprop(sym, @':callback', data); + si_put_sysprop(sym, @':callback', data); @(return closure_object); } @) diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index cbdb738bb..db85e4897 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -35,38 +35,38 @@ backtrace(void **buffer, int n) int nframes = (n > 32)? 32 : n; int i; switch (nframes) { - case 32: buffer[31] = __builtin_return_address(31); - case 31: buffer[30] = __builtin_return_address(30); - case 30: buffer[29] = __builtin_return_address(29); - case 29: buffer[28] = __builtin_return_address(28); - case 28: buffer[27] = __builtin_return_address(27); - case 27: buffer[26] = __builtin_return_address(26); - case 26: buffer[25] = __builtin_return_address(25); - case 25: buffer[24] = __builtin_return_address(24); - case 24: buffer[23] = __builtin_return_address(23); - case 23: buffer[22] = __builtin_return_address(22); - case 22: buffer[21] = __builtin_return_address(21); - case 21: buffer[20] = __builtin_return_address(20); - case 20: buffer[19] = __builtin_return_address(19); - case 19: buffer[18] = __builtin_return_address(18); - case 18: buffer[17] = __builtin_return_address(17); - case 17: buffer[16] = __builtin_return_address(16); - case 16: buffer[15] = __builtin_return_address(15); - case 15: buffer[14] = __builtin_return_address(14); - case 14: buffer[13] = __builtin_return_address(13); - case 13: buffer[12] = __builtin_return_address(12); - case 12: buffer[11] = __builtin_return_address(11); - case 11: buffer[10] = __builtin_return_address(10); - case 10: buffer[9] = __builtin_return_address(9); - case 9: buffer[8] = __builtin_return_address(8); - case 8: buffer[7] = __builtin_return_address(7); - case 7: buffer[6] = __builtin_return_address(6); - case 6: buffer[5] = __builtin_return_address(5); - case 5: buffer[4] = __builtin_return_address(4); - case 4: buffer[3] = __builtin_return_address(3); - case 3: buffer[2] = __builtin_return_address(2); - case 2: buffer[1] = __builtin_return_address(1); - case 1: buffer[0] = __builtin_return_address(0); + case 32: buffer[31] = __builtin_return_address(31); + case 31: buffer[30] = __builtin_return_address(30); + case 30: buffer[29] = __builtin_return_address(29); + case 29: buffer[28] = __builtin_return_address(28); + case 28: buffer[27] = __builtin_return_address(27); + case 27: buffer[26] = __builtin_return_address(26); + case 26: buffer[25] = __builtin_return_address(25); + case 25: buffer[24] = __builtin_return_address(24); + case 24: buffer[23] = __builtin_return_address(23); + case 23: buffer[22] = __builtin_return_address(22); + case 22: buffer[21] = __builtin_return_address(21); + case 21: buffer[20] = __builtin_return_address(20); + case 20: buffer[19] = __builtin_return_address(19); + case 19: buffer[18] = __builtin_return_address(18); + case 18: buffer[17] = __builtin_return_address(17); + case 17: buffer[16] = __builtin_return_address(16); + case 16: buffer[15] = __builtin_return_address(15); + case 15: buffer[14] = __builtin_return_address(14); + case 14: buffer[13] = __builtin_return_address(13); + case 13: buffer[12] = __builtin_return_address(12); + case 12: buffer[11] = __builtin_return_address(11); + case 11: buffer[10] = __builtin_return_address(10); + case 10: buffer[9] = __builtin_return_address(9); + case 9: buffer[8] = __builtin_return_address(8); + case 8: buffer[7] = __builtin_return_address(7); + case 7: buffer[6] = __builtin_return_address(6); + case 6: buffer[5] = __builtin_return_address(5); + case 5: buffer[4] = __builtin_return_address(4); + case 4: buffer[3] = __builtin_return_address(3); + case 3: buffer[2] = __builtin_return_address(2); + case 2: buffer[1] = __builtin_return_address(1); + case 1: buffer[0] = __builtin_return_address(0); } return nframes; } diff --git a/src/c/ffi/cdata.d b/src/c/ffi/cdata.d index 94a1405e9..17f0b5510 100644 --- a/src/c/ffi/cdata.d +++ b/src/c/ffi/cdata.d @@ -42,7 +42,7 @@ si_get_cdata(cl_object filename) } if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) { - displaced = str_no_data; + displaced = str_no_data; } else { displaced = cl_funcall(8, @'make-array', ecl_make_fixnum(header->size), diff --git a/src/c/ffi/libraries.d b/src/c/ffi/libraries.d index 530f1529d..9f2dd4659 100644 --- a/src/c/ffi/libraries.d +++ b/src/c/ffi/libraries.d @@ -18,9 +18,9 @@ /* * Choosing the interface for loading binary files. Currently we recognize * three different methods: - * - Windows API, provided by ECL_MS_WINDOWS_HOST - * - dlopen, provided HAVE_DLFCN_H is defined - * - NSLinkModule, provided HAVE_MACH_O_DYLD_H is defined + * - Windows API, provided by ECL_MS_WINDOWS_HOST + * - dlopen, provided HAVE_DLFCN_H is defined + * - NSLinkModule, provided HAVE_MACH_O_DYLD_H is defined * They are chosen in this precise order. In order to make the code for these * methods mutually exclusive, when one method is present, the other macros * get undefined. Handling of dynamically loaded libraries is constrained to @@ -92,7 +92,7 @@ ecl_make_codeblock() block->cblock.cfuns_size = 0; block->cblock.cfuns = NULL; block->cblock.source = ECL_NIL; - block->cblock.error = ECL_NIL; + block->cblock.error = ECL_NIL; block->cblock.refs = ecl_make_fixnum(0); si_set_finalizer(block, ECL_T); return block; @@ -101,9 +101,9 @@ ecl_make_codeblock() static cl_object copy_object_file(cl_object original) { - int err; - cl_object copy = make_constant_base_string("TMP:ECL"); - copy = si_coerce_to_filename(si_mkstemp(copy)); + int err; + cl_object copy = make_constant_base_string("TMP:ECL"); + copy = si_coerce_to_filename(si_mkstemp(copy)); /* * We either have to make a full copy to convince the loader to load this object * file again, or we want to retain the possibility of overwriting the object @@ -111,98 +111,98 @@ copy_object_file(cl_object original) * The symlinks do not seem to work in latest versions of Linux. */ #if defined(ECL_MS_WINDOWS_HOST) - ecl_disable_interrupts(); - err = !CopyFile(original->base_string.self, copy->base_string.self, 0); - ecl_enable_interrupts(); - if (err) { - FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + ecl_disable_interrupts(); + err = !CopyFile(original->base_string.self, copy->base_string.self, 0); + ecl_enable_interrupts(); + if (err) { + FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #else - err = Null(si_copy_file(original, copy)); - if (err) { - FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", - 2, original, copy); - } + err = Null(si_copy_file(original, copy)); + if (err) { + FEerror("Error when copying file from~&~3T~A~&to~&~3T~A", + 2, original, copy); + } #endif #ifdef cygwin - { - cl_object new_copy = make_constant_base_string(".dll"); - new_copy = si_base_string_concatenate(2, copy, new_copy); - cl_rename_file(2, copy, new_copy); - copy = new_copy; - } - ecl_disable_interrupts(); - err = chmod(copy->base_string.self, S_IRWXU) < 0; - ecl_enable_interrupts(); - if (err) { - FElibc_error("Unable to give executable permissions to ~A", - 1, copy); - } + { + cl_object new_copy = make_constant_base_string(".dll"); + new_copy = si_base_string_concatenate(2, copy, new_copy); + cl_rename_file(2, copy, new_copy); + copy = new_copy; + } + ecl_disable_interrupts(); + err = chmod(copy->base_string.self, S_IRWXU) < 0; + ecl_enable_interrupts(); + if (err) { + FElibc_error("Unable to give executable permissions to ~A", + 1, copy); + } #endif - return copy; + return copy; } #ifdef ENABLE_DLOPEN static void set_library_error(cl_object block) { - cl_object output; - ecl_disable_interrupts(); + cl_object output; + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - output = make_base_string_copy(dlerror()); + output = make_base_string_copy(dlerror()); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSLinkEditErrors c; - int number; - const char *filename; - NSLinkEditError(&c, &number, &filename, &message); - output = make_base_string_copy(message); - } + { + NSLinkEditErrors c; + int number; + const char *filename; + NSLinkEditError(&c, &number, &filename, &message); + output = make_base_string_copy(message); + } #endif #if defined(ECL_MS_WINDOWS_HOST) - { - const char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - output = make_base_string_copy(message); - LocalFree(message); - } + { + const char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + output = make_base_string_copy(message); + LocalFree(message); + } #endif - ecl_enable_interrupts(); - block->cblock.error = output; + ecl_enable_interrupts(); + block->cblock.error = output; } static void dlopen_wrapper(cl_object block) { - cl_object filename = block->cblock.name; + cl_object filename = block->cblock.name; char *filename_string = (char*)filename->base_string.self; #ifdef HAVE_DLFCN_H - block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); + block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); #endif #ifdef HAVE_MACH_O_DYLD_H - { - NSObjectFileImage file; + { + NSObjectFileImage file; static NSObjectFileImageReturnCode code; - code = NSCreateObjectFileImageFromFile(filename_string, &file); - if (code != NSObjectFileImageSuccess) { - block->cblock.handle = NULL; - } else { - NSModule out = NSLinkModule(file, filename_string, - NSLINKMODULE_OPTION_PRIVATE| - NSLINKMODULE_OPTION_BINDNOW| - NSLINKMODULE_OPTION_RETURN_ON_ERROR); - block->cblock.handle = out; - }} + code = NSCreateObjectFileImageFromFile(filename_string, &file); + if (code != NSObjectFileImageSuccess) { + block->cblock.handle = NULL; + } else { + NSModule out = NSLinkModule(file, filename_string, + NSLINKMODULE_OPTION_PRIVATE| + NSLINKMODULE_OPTION_BINDNOW| + NSLINKMODULE_OPTION_RETURN_ON_ERROR); + block->cblock.handle = out; + }} #endif #if defined(ECL_MS_WINDOWS_HOST) - block->cblock.handle = LoadLibrary(filename_string); + block->cblock.handle = LoadLibrary(filename_string); #endif - if (block->cblock.handle == NULL) - set_library_error(block); + if (block->cblock.handle == NULL) + set_library_error(block); } static int @@ -227,41 +227,41 @@ dlclose_wrapper(cl_object block) static cl_object ecl_library_find_by_name(cl_object filename) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - cl_object name = other->cblock.name; - if (!Null(name) && ecl_string_eq(name, filename)) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + cl_object name = other->cblock.name; + if (!Null(name) && ecl_string_eq(name, filename)) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_find_by_handle(void *handle) { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object other = ECL_CONS_CAR(l); - if (handle == other->cblock.handle) { - return other; - } - } - return ECL_NIL; + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); + if (handle == other->cblock.handle) { + return other; + } + } + return ECL_NIL; } static cl_object ecl_library_open_inner(cl_object filename, bool self_destruct) { const cl_env_ptr the_env = ecl_process_env(); - cl_object block = ecl_make_codeblock(); - block->cblock.self_destruct = self_destruct; - block->cblock.name = filename; + cl_object block = ecl_make_codeblock(); + block->cblock.self_destruct = self_destruct; + block->cblock.name = filename; block->cblock.refs = ecl_make_fixnum(1); ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) { - ecl_disable_interrupts(); + ecl_disable_interrupts(); GC_call_with_alloc_lock(dlopen_wrapper, block); if (block->cblock.handle != NULL) { /* Have we already loaded this library? If so, then unload this @@ -270,7 +270,7 @@ ecl_library_open_inner(cl_object filename, bool self_destruct) */ cl_object other = ecl_library_find_by_handle(block->cblock.handle); if (other != ECL_NIL) { - GC_call_with_alloc_lock(dlclose_wrapper, block); + GC_call_with_alloc_lock(dlclose_wrapper, block); block = other; block->cblock.refs = ecl_one_plus(block->cblock.refs); } else { @@ -278,147 +278,147 @@ ecl_library_open_inner(cl_object filename, bool self_destruct) cl_core.libraries = CONS(block, cl_core.libraries); } } - ecl_enable_interrupts(); + ecl_enable_interrupts(); } ECL_WITH_GLOBAL_LOCK_END; return block; } cl_object ecl_library_open(cl_object filename, bool force_reload) { - cl_object block; - bool self_destruct = 0; - char *filename_string; + cl_object block; + bool self_destruct = 0; + char *filename_string; - /* Coerces to a file name but does not merge with cwd */ - filename = coerce_to_physical_pathname(filename); + /* Coerces to a file name but does not merge with cwd */ + filename = coerce_to_physical_pathname(filename); filename = ecl_namestring(filename, ECL_NAMESTRING_TRUNCATE_IF_ERROR | ECL_NAMESTRING_FORCE_BASE_STRING); - if (!force_reload) { - /* When loading a foreign library, such as a dll or a - * so, it cannot contain any executable top level - * code. In that case force_reload=0 and there is no - * need to reload it if it has already been loaded. */ - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - return block; - } - } else { - /* We are using shared libraries as modules and - * force_reload=1. Here we have to face the problem - * that many operating systems do not allow to load a - * shared library twice, even if it has changed. Hence - * we have to make a unique copy to be able to load - * the same FASL twice. In Windows this copy is - * _always_ made because otherwise it cannot be - * overwritten. In Unix we need only do that when the - * file has been previously loaded. */ + if (!force_reload) { + /* When loading a foreign library, such as a dll or a + * so, it cannot contain any executable top level + * code. In that case force_reload=0 and there is no + * need to reload it if it has already been loaded. */ + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + return block; + } + } else { + /* We are using shared libraries as modules and + * force_reload=1. Here we have to face the problem + * that many operating systems do not allow to load a + * shared library twice, even if it has changed. Hence + * we have to make a unique copy to be able to load + * the same FASL twice. In Windows this copy is + * _always_ made because otherwise it cannot be + * overwritten. In Unix we need only do that when the + * file has been previously loaded. */ #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) - filename = copy_object_file(filename); - self_destruct = 1; + filename = copy_object_file(filename); + self_destruct = 1; #else - block = ecl_library_find_by_name(filename); - if (!Null(block)) { - filename = copy_object_file(filename); - self_destruct = 1; - } + block = ecl_library_find_by_name(filename); + if (!Null(block)) { + filename = copy_object_file(filename); + self_destruct = 1; + } #endif - } + } DO_LOAD: block = ecl_library_open_inner(filename, self_destruct); - /* - * A second pass to ensure that the dlopen routine has not - * returned a library that we had already loaded. If this is - * the case, we close the new copy to ensure we do refcounting - * right. - */ - if (block->cblock.refs != ecl_make_fixnum(1)) { + /* + * A second pass to ensure that the dlopen routine has not + * returned a library that we had already loaded. If this is + * the case, we close the new copy to ensure we do refcounting + * right. + */ + if (block->cblock.refs != ecl_make_fixnum(1)) { if (force_reload) { ecl_library_close(block); filename = copy_object_file(filename); self_destruct = 1; goto DO_LOAD; } - } - return block; + } + return block; } void * ecl_library_symbol(cl_object block, const char *symbol, bool lock) { - void *p; - if (block == @':default') { - cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object block = ECL_CONS_CAR(l); - p = ecl_library_symbol(block, symbol, lock); - if (p) return p; - } - ecl_disable_interrupts(); + void *p; + if (block == @':default') { + cl_object l; + for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object block = ECL_CONS_CAR(l); + p = ecl_library_symbol(block, symbol, lock); + if (p) return p; + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - { - HANDLE hndSnap = NULL; - HANDLE hnd = NULL; - hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); - if (hndSnap != INVALID_HANDLE_VALUE) - { - MODULEENTRY32 me32; - me32.dwSize = sizeof(MODULEENTRY32); - if (Module32First(hndSnap, &me32)) - { - do - hnd = GetProcAddress(me32.hModule, symbol); - while (hnd == NULL && Module32Next(hndSnap, &me32)); - } - CloseHandle(hndSnap); - } - p = (void*)hnd; - } + { + HANDLE hndSnap = NULL; + HANDLE hnd = NULL; + hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); + if (hndSnap != INVALID_HANDLE_VALUE) + { + MODULEENTRY32 me32; + me32.dwSize = sizeof(MODULEENTRY32); + if (Module32First(hndSnap, &me32)) + { + do + hnd = GetProcAddress(me32.hModule, symbol); + while (hnd == NULL && Module32Next(hndSnap, &me32)); + } + CloseHandle(hndSnap); + } + p = (void*)hnd; + } #endif #ifdef HAVE_DLFCN_H - p = dlsym(0, symbol); + p = dlsym(0, symbol); #endif #if !defined(ECL_MS_WINDOWS_HOST) && !defined(HAVE_DLFCN_H) - p = 0; + p = 0; #endif - ecl_enable_interrupts(); - } else { - ecl_disable_interrupts(); + ecl_enable_interrupts(); + } else { + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - p = dlsym(block->cblock.handle, symbol); + p = dlsym(block->cblock.handle, symbol); #endif #if defined(ECL_MS_WINDOWS_HOST) - { - HMODULE h = (HMODULE)(block->cblock.handle); - p = GetProcAddress(h, symbol); - } + { + HMODULE h = (HMODULE)(block->cblock.handle); + p = GetProcAddress(h, symbol); + } #endif #ifdef HAVE_MACH_O_DYLD_H - NSSymbol sym; - sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), - symbol); - if (sym == 0) { - p = 0; - } else { - p = NSAddressOfSymbol(sym); - } + NSSymbol sym; + sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle), + symbol); + if (sym == 0) { + p = 0; + } else { + p = NSAddressOfSymbol(sym); + } #endif - ecl_enable_interrupts(); - /* Libraries whose symbols are being referenced by the FFI should not - * get garbage collected. Until we find a better solution we simply lock - * them for the rest of the runtime */ - if (p) { - block->cblock.locked |= lock; - } - } - if (!p) - set_library_error(block); - return p; + ecl_enable_interrupts(); + /* Libraries whose symbols are being referenced by the FFI should not + * get garbage collected. Until we find a better solution we simply lock + * them for the rest of the runtime */ + if (p) { + block->cblock.locked |= lock; + } + } + if (!p) + set_library_error(block); + return p; } cl_object ecl_library_error(cl_object block) { - return block->cblock.error; + return block->cblock.error; } bool @@ -440,7 +440,7 @@ ecl_library_close(cl_object block) { } ecl_enable_interrupts(); } ECL_WITH_GLOBAL_LOCK_END; - if (block != ECL_NIL && block->cblock.self_destruct) { + if (block != ECL_NIL && block->cblock.self_destruct) { if (!Null(block->cblock.name)) { unlink((char*)block->cblock.name->base_string.self); } @@ -451,9 +451,9 @@ ecl_library_close(cl_object block) { void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); - } + while (cl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + } } ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, const); @@ -461,7 +461,7 @@ ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, cl_object _ecl_library_init_prefix(void) { - return init_prefix; + return init_prefix; } ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CODE")-1, @@ -470,6 +470,6 @@ ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CO cl_object _ecl_library_default_entry(void) { - return default_entry; + return default_entry; } #endif /* ENABLE_DLOPEN */ diff --git a/src/c/file.d b/src/c/file.d index 9087f2f4d..773a0ea01 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -16,10 +16,10 @@ */ /* - IMPLEMENTATION-DEPENDENT + IMPLEMENTATION-DEPENDENT - The file contains code to reclaim the I/O buffer - by accessing the FILE structure of C. + The file contains code to reclaim the I/O buffer + by accessing the FILE structure of C. */ #include @@ -102,129 +102,129 @@ static void wsock_error( const char *err_msg, cl_object strm ) ecl_attr_noreturn static cl_index not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_output_stream(strm); - return 0; + not_an_output_stream(strm); + return 0; } static cl_index not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_an_input_stream(strm); - return 0; + not_an_input_stream(strm); + return 0; } static cl_index not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - not_a_binary_stream(strm); - return 0; + not_a_binary_stream(strm); + return 0; } static void not_output_write_byte(cl_object c, cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static cl_object not_input_read_byte(cl_object strm) { - not_an_input_stream(strm); - return OBJNULL; + not_an_input_stream(strm); + return OBJNULL; } static void not_binary_write_byte(cl_object c, cl_object strm) { - not_a_binary_stream(strm); + not_a_binary_stream(strm); } static cl_object not_binary_read_byte(cl_object strm) { - not_a_binary_stream(strm); - return OBJNULL; + not_a_binary_stream(strm); + return OBJNULL; } static ecl_character not_input_read_char(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_output_write_char(cl_object strm, ecl_character c) { - not_an_output_stream(strm); - return c; + not_an_output_stream(strm); + return c; } static void not_input_unread_char(cl_object strm, ecl_character c) { - not_an_input_stream(strm); + not_an_input_stream(strm); } static int not_input_listen(cl_object strm) { - not_an_input_stream(strm); - return -1; + not_an_input_stream(strm); + return -1; } static ecl_character not_character_read_char(cl_object strm) { - not_a_character_stream(strm); - return -1; + not_a_character_stream(strm); + return -1; } static ecl_character not_character_write_char(cl_object strm, ecl_character c) { - not_a_character_stream(strm); - return c; + not_a_character_stream(strm); + return c; } static void not_input_clear_input(cl_object strm) { - not_an_input_stream(strm); - return; + not_an_input_stream(strm); + return; } static void not_output_clear_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_force_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } static void not_output_finish_output(cl_object strm) { - not_an_output_stream(strm); + not_an_output_stream(strm); } #if defined(ECL_WSOCK) static cl_object not_implemented_get_position(cl_object strm) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } static cl_object not_implemented_set_position(cl_object strm, cl_object pos) { - FEerror("file-position not implemented for stream ~S", 1, strm); - return ECL_NIL; + FEerror("file-position not implemented for stream ~S", 1, strm); + return ECL_NIL; } #endif @@ -235,48 +235,48 @@ not_implemented_set_position(cl_object strm, cl_object pos) static cl_index closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static cl_index closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_read_char(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static ecl_character closed_stream_write_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); - return c; + FEclosed_stream(strm); + return c; } static void closed_stream_unread_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); + FEclosed_stream(strm); } static int closed_stream_listen(cl_object strm) { - FEclosed_stream(strm); - return 0; + FEclosed_stream(strm); + return 0; } static void closed_stream_clear_input(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_clear_output closed_stream_clear_input @@ -286,7 +286,7 @@ closed_stream_clear_input(cl_object strm) static cl_object closed_stream_length(cl_object strm) { - FEclosed_stream(strm); + FEclosed_stream(strm); } #define closed_stream_get_position closed_stream_length @@ -294,7 +294,7 @@ closed_stream_length(cl_object strm) static cl_object closed_stream_set_position(cl_object strm, cl_object position) { - FEclosed_stream(strm); + FEclosed_stream(strm); } /********************************************************************** @@ -308,123 +308,123 @@ closed_stream_set_position(cl_object strm, cl_object position) static cl_object generic_read_byte_unsigned8(cl_object strm) { - unsigned char c; - if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { - return ECL_NIL; - } - return ecl_make_fixnum(c); + unsigned char c; + if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) { + return ECL_NIL; + } + return ecl_make_fixnum(c); } static void generic_write_byte_unsigned8(cl_object byte, cl_object strm) { - unsigned char c = ecl_to_uint8_t(byte); - strm->stream.ops->write_byte8(strm, &c, 1); + unsigned char c = ecl_to_uint8_t(byte); + strm->stream.ops->write_byte8(strm, &c, 1); } static cl_object generic_read_byte_signed8(cl_object strm) { - signed char c; - if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) - return ECL_NIL; - return ecl_make_fixnum(c); + signed char c; + if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1) + return ECL_NIL; + return ecl_make_fixnum(c); } static void generic_write_byte_signed8(cl_object byte, cl_object strm) { - signed char c = fixint(byte); - strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); + signed char c = fixint(byte); + strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1); } static cl_object generic_read_byte_le(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_index nb, bs; - cl_object output = ecl_make_fixnum(0); - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (nb = 0; bs >= 8; bs -= 8, nb += 8) { - cl_object aux; - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) - aux = ecl_make_fixnum((signed char)c); - else - aux = ecl_make_fixnum((unsigned char)c); - output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_index nb, bs; + cl_object output = ecl_make_fixnum(0); + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (nb = 0; bs >= 8; bs -= 8, nb += 8) { + cl_object aux; + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) + aux = ecl_make_fixnum((signed char)c); + else + aux = ecl_make_fixnum((unsigned char)c); + output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb))); + } + return output; } static void generic_write_byte_le(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); - unsigned char aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - c = cl_ash(c, ecl_make_fixnum(-8)); - bs -= 8; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + cl_object b = cl_logand(2, c, ecl_make_fixnum(0xFF)); + unsigned char aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + c = cl_ash(c, ecl_make_fixnum(-8)); + bs -= 8; + } while (bs); } static cl_object generic_read_byte(cl_object strm) { - cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); - unsigned char c; - cl_object output = NULL; - cl_index bs; - read_byte8 = strm->stream.ops->read_byte8; - bs = strm->stream.byte_size; - for (; bs >= 8; bs -= 8) { - if (read_byte8(strm, &c, 1) < 1) - return ECL_NIL; - if (output) { - output = cl_logior(2, ecl_make_fixnum(c), - cl_ash(output, ecl_make_fixnum(8))); - } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { - output = ecl_make_fixnum((signed char)c); - } else { - output = ecl_make_fixnum((unsigned char)c); - } - } - return output; + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + unsigned char c; + cl_object output = NULL; + cl_index bs; + read_byte8 = strm->stream.ops->read_byte8; + bs = strm->stream.byte_size; + for (; bs >= 8; bs -= 8) { + if (read_byte8(strm, &c, 1) < 1) + return ECL_NIL; + if (output) { + output = cl_logior(2, ecl_make_fixnum(c), + cl_ash(output, ecl_make_fixnum(8))); + } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { + output = ecl_make_fixnum((signed char)c); + } else { + output = ecl_make_fixnum((unsigned char)c); + } + } + return output; } static void generic_write_byte(cl_object c, cl_object strm) { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index bs; - write_byte8 = strm->stream.ops->write_byte8; - bs = strm->stream.byte_size; - do { - unsigned char aux; - cl_object b; - bs -= 8; - b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); - aux = (unsigned char)ecl_fixnum(b); - if (write_byte8(strm, &aux, 1) < 1) - break; - } while (bs); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + write_byte8 = strm->stream.ops->write_byte8; + bs = strm->stream.byte_size; + do { + unsigned char aux; + cl_object b; + bs -= 8; + b = cl_logand(2, ecl_make_fixnum(0xFF), bs? cl_ash(c, ecl_make_fixnum(-bs)) : c); + aux = (unsigned char)ecl_fixnum(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + } while (bs); } static ecl_character generic_peek_char(cl_object strm) { - ecl_character out = ecl_read_char(strm); - if (out != EOF) ecl_unread_char(out, strm); - return out; + ecl_character out = ecl_read_char(strm); + if (out != EOF) ecl_unread_char(out, strm); + return out; } static void @@ -435,111 +435,111 @@ generic_void(cl_object strm) static int generic_always_true(cl_object strm) { - return 1; + return 1; } static int generic_always_false(cl_object strm) { - return 0; + return 0; } static cl_object generic_always_nil(cl_object strm) { - return ECL_NIL; + return ECL_NIL; } static int generic_column(cl_object strm) { - return 0; + return 0; } static cl_object generic_set_position(cl_object strm, cl_object pos) { - return ECL_NIL; + return ECL_NIL; } static cl_object generic_close(cl_object strm) { - struct ecl_file_ops *ops = strm->stream.ops; - if (ecl_input_stream_p(strm)) { - ops->read_byte8 = closed_stream_read_byte8; - ops->read_char = closed_stream_read_char; - ops->unread_char = closed_stream_unread_char; - ops->listen = closed_stream_listen; - ops->clear_input = closed_stream_clear_input; - } - if (ecl_output_stream_p(strm)) { - ops->write_byte8 = closed_stream_write_byte8; - ops->write_char = closed_stream_write_char; - ops->clear_output = closed_stream_clear_output; - ops->force_output = closed_stream_force_output; - ops->finish_output = closed_stream_finish_output; - } - ops->get_position = closed_stream_get_position; - ops->set_position = closed_stream_set_position; - ops->length = closed_stream_length; - ops->close = generic_close; - strm->stream.closed = 1; - return ECL_T; + struct ecl_file_ops *ops = strm->stream.ops; + if (ecl_input_stream_p(strm)) { + ops->read_byte8 = closed_stream_read_byte8; + ops->read_char = closed_stream_read_char; + ops->unread_char = closed_stream_unread_char; + ops->listen = closed_stream_listen; + ops->clear_input = closed_stream_clear_input; + } + if (ecl_output_stream_p(strm)) { + ops->write_byte8 = closed_stream_write_byte8; + ops->write_char = closed_stream_write_char; + ops->clear_output = closed_stream_clear_output; + ops->force_output = closed_stream_force_output; + ops->finish_output = closed_stream_finish_output; + } + ops->get_position = closed_stream_get_position; + ops->set_position = closed_stream_set_position; + ops->length = closed_stream_length; + ops->close = generic_close; + strm->stream.closed = 1; + return ECL_T; } static cl_index generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype elttype; - const struct ecl_file_ops *ops; - if (start >= end) - return start; - ops = stream_dispatch_table(strm); - elttype = ecl_array_elttype(data); - if (elttype == ecl_aet_bc || + cl_elttype elttype; + const struct ecl_file_ops *ops; + if (start >= end) + return start; + ops = stream_dispatch_table(strm); + elttype = ecl_array_elttype(data); + if (elttype == ecl_aet_bc || #ifdef ECL_UNICODE - elttype == ecl_aet_ch || + elttype == ecl_aet_ch || #endif - (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { - ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; - for (; start < end; start++) { - write_char(strm, ecl_char_code(ecl_elt(data, start))); - } - } else { - void (*write_byte)(cl_object, cl_object) = ops->write_byte; - for (; start < end; start++) { - write_byte(ecl_elt(data, start), strm); - } - } - return start; + (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) { + ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char; + for (; start < end; start++) { + write_char(strm, ecl_char_code(ecl_elt(data, start))); + } + } else { + void (*write_byte)(cl_object, cl_object) = ops->write_byte; + for (; start < end; start++) { + write_byte(ecl_elt(data, start), strm); + } + } + return start; } static cl_index generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - const struct ecl_file_ops *ops; - cl_object expected_type; - if (start >= end) - return start; - expected_type = ecl_stream_element_type(strm); - ops = stream_dispatch_table(strm); - if (expected_type == @'base-char' || expected_type == @'character') { - ecl_character (*read_char)(cl_object) = ops->read_char; - for (; start < end; start++) { - cl_fixnum c = read_char(strm); - if (c == EOF) break; - ecl_elt_set(data, start, ECL_CODE_CHAR(c)); - } - } else { - cl_object (*read_byte)(cl_object) = ops->read_byte; - for (; start < end; start++) { - cl_object x = read_byte(strm); - if (Null(x)) break; - ecl_elt_set(data, start, x); - } - } - return start; + const struct ecl_file_ops *ops; + cl_object expected_type; + if (start >= end) + return start; + expected_type = ecl_stream_element_type(strm); + ops = stream_dispatch_table(strm); + if (expected_type == @'base-char' || expected_type == @'character') { + ecl_character (*read_char)(cl_object) = ops->read_char; + for (; start < end; start++) { + cl_fixnum c = read_char(strm); + if (c == EOF) break; + ecl_elt_set(data, start, ECL_CODE_CHAR(c)); + } + } else { + cl_object (*read_byte)(cl_object) = ops->read_byte; + for (; start < end; start++) { + cl_object x = read_byte(strm); + if (Null(x)) break; + ecl_elt_set(data, start, x); + } + } + return start; } /********************************************************************** @@ -549,113 +549,113 @@ generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end static void eformat_unread_char(cl_object strm, ecl_character c) { - unlikely_if (c != strm->stream.last_char) { - unread_twice(strm); - } - { - unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; - int ndx = 0; - cl_object l = strm->stream.byte_stack; - cl_fixnum i = strm->stream.last_code[0]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer, i); - } - i = strm->stream.last_code[1]; - if (i != EOF) { - ndx += strm->stream.encoder(strm, buffer+ndx, i); - } - while (ndx != 0) { - l = CONS(ecl_make_fixnum(buffer[--ndx]), l); - } - strm->stream.byte_stack = l; - strm->stream.last_char = EOF; - } + unlikely_if (c != strm->stream.last_char) { + unread_twice(strm); + } + { + unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE]; + int ndx = 0; + cl_object l = strm->stream.byte_stack; + cl_fixnum i = strm->stream.last_code[0]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer, i); + } + i = strm->stream.last_code[1]; + if (i != EOF) { + ndx += strm->stream.encoder(strm, buffer+ndx, i); + } + while (ndx != 0) { + l = CONS(ecl_make_fixnum(buffer[--ndx]), l); + } + strm->stream.byte_stack = l; + strm->stream.last_char = EOF; + } } static ecl_character eformat_read_char(cl_object strm) { - ecl_character c = strm->stream.decoder(strm); - unlikely_if (c == strm->stream.eof_char) - return EOF; - if (c != EOF) { - strm->stream.last_char = c; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - return c; + ecl_character c = strm->stream.decoder(strm); + unlikely_if (c == strm->stream.eof_char) + return EOF; + if (c != EOF) { + strm->stream.last_char = c; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + return c; } static ecl_character eformat_write_char(cl_object strm, ecl_character c) { - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - ecl_character nbytes; - nbytes = strm->stream.encoder(strm, buffer, c); - strm->stream.ops->write_byte8(strm, buffer, nbytes); - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; - else - strm->stream.column++; - fflush(stdout); - return c; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + ecl_character nbytes; + nbytes = strm->stream.encoder(strm, buffer, c); + strm->stream.ops->write_byte8(strm, buffer, nbytes); + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8; + else + strm->stream.column++; + fflush(stdout); + return c; } static ecl_character eformat_read_char_cr(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = ECL_CHAR_CODE_NEWLINE; - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = ECL_CHAR_CODE_NEWLINE; + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_cr(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } static ecl_character eformat_read_char_crlf(cl_object strm) { - ecl_character c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_RETURN) { - c = eformat_read_char(strm); - if (c == ECL_CHAR_CODE_LINEFEED) { - strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[1] = c; - c = ECL_CHAR_CODE_NEWLINE; - } else { - eformat_unread_char(strm, c); - c = ECL_CHAR_CODE_RETURN; - strm->stream.last_code[0] = c; - strm->stream.last_code[1] = EOF; - } - strm->stream.last_char = c; - } - return c; + ecl_character c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_RETURN) { + c = eformat_read_char(strm); + if (c == ECL_CHAR_CODE_LINEFEED) { + strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[1] = c; + c = ECL_CHAR_CODE_NEWLINE; + } else { + eformat_unread_char(strm, c); + c = ECL_CHAR_CODE_RETURN; + strm->stream.last_code[0] = c; + strm->stream.last_code[1] = EOF; + } + strm->stream.last_char = c; + } + return c; } static ecl_character eformat_write_char_crlf(cl_object strm, ecl_character c) { - if (c == ECL_CHAR_CODE_NEWLINE) { - eformat_write_char(strm, ECL_CHAR_CODE_RETURN); - eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); - strm->stream.column = 0; - return c; - } - return eformat_write_char(strm, c); + if (c == ECL_CHAR_CODE_NEWLINE) { + eformat_write_char(strm, ECL_CHAR_CODE_RETURN); + eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED); + strm->stream.column = 0; + return c; + } + return eformat_write_char(strm, c); } /* @@ -667,23 +667,23 @@ eformat_write_char_crlf(cl_object strm, ecl_character c) static ecl_character passthrough_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) - return EOF; - else - return aux; + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) + return EOF; + else + return aux; } static int passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { #ifdef ECL_UNICODE - unlikely_if (c > 0xFF) { - return encoding_error(stream, buffer, c); - } + unlikely_if (c > 0xFF) { + return encoding_error(stream, buffer, c); + } #endif - buffer[0] = c; - return 1; + buffer[0] = c; + return 1; } #ifdef ECL_UNICODE @@ -694,24 +694,24 @@ passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ascii_decoder(cl_object stream) { - unsigned char aux; - if (ecl_read_byte8(stream, &aux, 1) < 1) { - return EOF; - } else if (aux > 127) { - return decoding_error(stream, &aux, 1); - } else { - return aux; - } + unsigned char aux; + if (ecl_read_byte8(stream, &aux, 1) < 1) { + return EOF; + } else if (aux > 127) { + return decoding_error(stream, &aux, 1); + } else { + return aux; + } } static int ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - unlikely_if (c > 127) { - return encoding_error(stream, buffer, c); - } - buffer[0] = c; - return 1; + unlikely_if (c > 127) { + return encoding_error(stream, buffer, c); + } + buffer[0] = c; + return 1; } /* @@ -721,22 +721,22 @@ ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4be_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[3]+(buffer[2]<<8)+(buffer[1]<<16)+(buffer[0]<<24); + } } static int ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[3] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 4; + buffer[3] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 4; } /* @@ -746,22 +746,22 @@ ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4le_decoder(cl_object stream) { - unsigned char buffer[4]; - if (ecl_read_byte8(stream, buffer, 4) < 4) { - return EOF; - } else { - return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); - } + unsigned char buffer[4]; + if (ecl_read_byte8(stream, buffer, 4) < 4) { + return EOF; + } else { + return buffer[0]+(buffer[1]<<8)+(buffer[2]<<16)+(buffer[3]<<24); + } } static int ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; c >>= 8; - buffer[2] = c & 0xFF; c >>= 8; - buffer[3] = c; - return 4; + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; c >>= 8; + buffer[2] = c & 0xFF; c >>= 8; + buffer[3] = c; + return 4; } /* @@ -771,31 +771,31 @@ ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_4_decoder(cl_object stream) { - cl_fixnum c = ucs_4be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return ucs_4be_decoder(stream); - } else if (c == 0xFFFE0000) { - stream->stream.decoder = ucs_4le_decoder; - stream->stream.encoder = ucs_4le_encoder; - return ucs_4le_decoder(stream); - } else { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - return c; - } + cl_fixnum c = ucs_4be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return ucs_4be_decoder(stream); + } else if (c == 0xFFFE0000) { + stream->stream.decoder = ucs_4le_decoder; + stream->stream.encoder = ucs_4le_encoder; + return ucs_4le_decoder(stream); + } else { + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + return c; + } } static int ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_4be_decoder; - stream->stream.encoder = ucs_4be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - buffer[2] = buffer[3] = 0; - return 4 + ucs_4be_encoder(stream, buffer+4, c); + stream->stream.decoder = ucs_4be_decoder; + stream->stream.encoder = ucs_4be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + buffer[2] = buffer[3] = 0; + return 4 + ucs_4be_encoder(stream, buffer+4, c); } @@ -806,40 +806,40 @@ ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2be_decoder(cl_object stream) { - unsigned char buffer[2] = {0,0}; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; - if ((buffer[0] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 1); - } - aux = ((ecl_character)buffer[0] << 8) | buffer[1]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; - } + unsigned char buffer[2] = {0,0}; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[0] << 8) | buffer[1]; + if ((buffer[0] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 1); + } + aux = ((ecl_character)buffer[0] << 8) | buffer[1]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); - ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); - return 4; - } else { - buffer[1] = c & 0xFF; c >>= 8; - buffer[0] = c; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800); + ucs_2be_encoder(stream, buffer+2, (c & 0x3FFF) | 0xDC00); + return 4; + } else { + buffer[1] = c & 0xFF; c >>= 8; + buffer[0] = c; + return 2; + } } /* @@ -849,40 +849,40 @@ ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2le_decoder(cl_object stream) { - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; - if ((buffer[1] & 0xFC) == 0xD8) { - if (ecl_read_byte8(stream, buffer, 2) < 2) { - return EOF; - } else { - ecl_character aux; - if ((buffer[1] & 0xFC) != 0xDC) { - return decoding_error(stream, buffer, 2); - } - aux = ((ecl_character)buffer[1] << 8) | buffer[0]; - return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; - } - } - return c; - } + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character c = ((ecl_character)buffer[1] << 8) | buffer[0]; + if ((buffer[1] & 0xFC) == 0xD8) { + if (ecl_read_byte8(stream, buffer, 2) < 2) { + return EOF; + } else { + ecl_character aux; + if ((buffer[1] & 0xFC) != 0xDC) { + return decoding_error(stream, buffer, 2); + } + aux = ((ecl_character)buffer[1] << 8) | buffer[0]; + return ((c & 0x3FFF) << 10) + (aux & 0x3FFF) + 0x10000; + } + } + return c; + } } static int ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - if (c >= 0x10000) { - c -= 0x10000; - ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); - ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); - return 4; - } else { - buffer[0] = c & 0xFF; c >>= 8; - buffer[1] = c & 0xFF; - return 2; - } + if (c >= 0x10000) { + c -= 0x10000; + ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD8000); + ucs_2le_encoder(stream, buffer+2, (c & 0x3FFF) | 0xD800); + return 4; + } else { + buffer[0] = c & 0xFF; c >>= 8; + buffer[1] = c & 0xFF; + return 2; + } } /* @@ -892,30 +892,30 @@ ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character ucs_2_decoder(cl_object stream) { - ecl_character c = ucs_2be_decoder(stream); - if (c == 0xFEFF) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return ucs_2be_decoder(stream); - } else if (c == 0xFFFE) { - stream->stream.decoder = ucs_2le_decoder; - stream->stream.encoder = ucs_2le_encoder; - return ucs_2le_decoder(stream); - } else { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - return c; - } + ecl_character c = ucs_2be_decoder(stream); + if (c == 0xFEFF) { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return ucs_2be_decoder(stream); + } else if (c == 0xFFFE) { + stream->stream.decoder = ucs_2le_decoder; + stream->stream.encoder = ucs_2le_encoder; + return ucs_2le_decoder(stream); + } else { + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + return c; + } } static int ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - stream->stream.decoder = ucs_2be_decoder; - stream->stream.encoder = ucs_2be_encoder; - buffer[0] = 0xFF; - buffer[1] = 0xFE; - return 2 + ucs_2be_encoder(stream, buffer+2, c); + stream->stream.decoder = ucs_2be_decoder; + stream->stream.encoder = ucs_2be_encoder; + buffer[0] = 0xFF; + buffer[1] = 0xFE; + return 2 + ucs_2be_encoder(stream, buffer+2, c); } /* @@ -925,47 +925,47 @@ ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character user_decoder(cl_object stream) { - cl_object table = stream->stream.format_table; - cl_object character; - unsigned char buffer[2]; - if (ecl_read_byte8(stream, buffer, 1) < 1) { - return EOF; - } - character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 1); - } - if (character == ECL_T) { - if (ecl_read_byte8(stream, buffer+1, 1) < 1) { - return EOF; - } else { - cl_fixnum byte = (buffer[0]<<8) + buffer[1]; - character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, 2); - } - } - } - return ECL_CHAR_CODE(character); + cl_object table = stream->stream.format_table; + cl_object character; + unsigned char buffer[2]; + if (ecl_read_byte8(stream, buffer, 1) < 1) { + return EOF; + } + character = ecl_gethash_safe(ecl_make_fixnum(buffer[0]), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 1); + } + if (character == ECL_T) { + if (ecl_read_byte8(stream, buffer+1, 1) < 1) { + return EOF; + } else { + cl_fixnum byte = (buffer[0]<<8) + buffer[1]; + character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL); + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, 2); + } + } + } + return ECL_CHAR_CODE(character); } static int user_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); - if (Null(byte)) { - return encoding_error(stream, buffer, c); - } else { - cl_fixnum code = ecl_fixnum(byte); - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return 2; - } else { - buffer[0] = code; - return 1; - } - } + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL); + if (Null(byte)) { + return encoding_error(stream, buffer, c); + } else { + cl_fixnum code = ecl_fixnum(byte); + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return 2; + } else { + buffer[0] = code; + return 1; + } + } } /* @@ -975,74 +975,74 @@ user_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static ecl_character user_multistate_decoder(cl_object stream) { - cl_object table_list = stream->stream.format_table; - cl_object table = ECL_CONS_CAR(table_list); - cl_object character; - cl_fixnum i, j; - unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; - for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { - if (ecl_read_byte8(stream, buffer+i, 1) < 1) { - return EOF; - } - j = (j << 8) | buffer[i]; - character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); - if (ECL_CHARACTERP(character)) { - return ECL_CHAR_CODE(character); - } - unlikely_if (Null(character)) { - return decoding_error(stream, buffer, i); - } - if (character == ECL_T) { - /* Need more characters */ - continue; - } - if (CONSP(character)) { - /* Changed the state. */ - stream->stream.format_table = table_list = character; - table = ECL_CONS_CAR(table_list); - i = j = 0; - continue; - } - break; - } - FEerror("Internal error in decoder table.", 0); + cl_object table_list = stream->stream.format_table; + cl_object table = ECL_CONS_CAR(table_list); + cl_object character; + cl_fixnum i, j; + unsigned char buffer[ENCODING_BUFFER_MAX_SIZE]; + for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; i++) { + if (ecl_read_byte8(stream, buffer+i, 1) < 1) { + return EOF; + } + j = (j << 8) | buffer[i]; + character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL); + if (ECL_CHARACTERP(character)) { + return ECL_CHAR_CODE(character); + } + unlikely_if (Null(character)) { + return decoding_error(stream, buffer, i); + } + if (character == ECL_T) { + /* Need more characters */ + continue; + } + if (CONSP(character)) { + /* Changed the state. */ + stream->stream.format_table = table_list = character; + table = ECL_CONS_CAR(table_list); + i = j = 0; + continue; + } + break; + } + FEerror("Internal error in decoder table.", 0); } static int user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - cl_object table_list = stream->stream.format_table; - cl_object p = table_list; - do { - cl_object table = ECL_CONS_CAR(p); - cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); - if (!Null(byte)) { - cl_fixnum code = ecl_fixnum(byte); - ecl_character n = 0; - if (p != table_list) { - /* Must output a escape sequence */ - cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); - while (!Null(x)) { - buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); - buffer++; - x = ECL_CONS_CDR(x); - n++; - } - stream->stream.format_table = p; - } - if (code > 0xFF) { - buffer[1] = code & 0xFF; code >>= 8; - buffer[0] = code; - return n+2; - } else { - buffer[0] = code; - return n+1; - } - } - p = ECL_CONS_CDR(p); - } while (p != table_list); - /* Exhausted all lists */ - return encoding_error(stream, buffer, c); + cl_object table_list = stream->stream.format_table; + cl_object p = table_list; + do { + cl_object table = ECL_CONS_CAR(p); + cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL); + if (!Null(byte)) { + cl_fixnum code = ecl_fixnum(byte); + ecl_character n = 0; + if (p != table_list) { + /* Must output a escape sequence */ + cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL); + while (!Null(x)) { + buffer[0] = ecl_fixnum(ECL_CONS_CAR(x)); + buffer++; + x = ECL_CONS_CDR(x); + n++; + } + stream->stream.format_table = p; + } + if (code > 0xFF) { + buffer[1] = code & 0xFF; code >>= 8; + buffer[0] = code; + return n+2; + } else { + buffer[0] = code; + return n+1; + } + } + p = ECL_CONS_CDR(p); + } while (p != table_list); + /* Exhausted all lists */ + return encoding_error(stream, buffer, c); } /* @@ -1052,80 +1052,80 @@ user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c static ecl_character utf_8_decoder(cl_object stream) { - /* In understanding this code: - * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 - * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 - */ - ecl_character cum = 0; - unsigned char buffer[5]; - int nbytes, i; - if (ecl_read_byte8(stream, buffer, 1) < 1) - return EOF; - if ((buffer[0] & 0x80) == 0) { - return buffer[0]; - } - unlikely_if ((buffer[0] & 0x40) == 0) - return decoding_error(stream, buffer, 1); - if ((buffer[0] & 0x20) == 0) { - cum = buffer[0] & 0x1F; - nbytes = 1; - } else if ((buffer[0] & 0x10) == 0) { - cum = buffer[0] & 0x0F; - nbytes = 2; - } else if ((buffer[0] & 0x08) == 0) { - cum = buffer[0] & 0x07; - nbytes = 3; - } else { - return decoding_error(stream, buffer, 1); - } - if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) - return EOF; - for (i = 1; i <= nbytes; i++) { - unsigned char c = buffer[i]; - /*printf(": %04x :", c);*/ - unlikely_if ((c & 0xC0) != 0x80) - return decoding_error(stream, buffer, nbytes+1); - cum = (cum << 6) | (c & 0x3F); - unlikely_if (cum == 0) - return decoding_error(stream, buffer, nbytes+1); - } - if (cum >= 0xd800) { - unlikely_if (cum <= 0xdfff) - return decoding_error(stream, buffer, nbytes+1); - unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) - return decoding_error(stream, buffer, nbytes+1); - } - /*printf("; %04x ;", cum);*/ - return cum; + /* In understanding this code: + * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 + * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 + */ + ecl_character cum = 0; + unsigned char buffer[5]; + int nbytes, i; + if (ecl_read_byte8(stream, buffer, 1) < 1) + return EOF; + if ((buffer[0] & 0x80) == 0) { + return buffer[0]; + } + unlikely_if ((buffer[0] & 0x40) == 0) + return decoding_error(stream, buffer, 1); + if ((buffer[0] & 0x20) == 0) { + cum = buffer[0] & 0x1F; + nbytes = 1; + } else if ((buffer[0] & 0x10) == 0) { + cum = buffer[0] & 0x0F; + nbytes = 2; + } else if ((buffer[0] & 0x08) == 0) { + cum = buffer[0] & 0x07; + nbytes = 3; + } else { + return decoding_error(stream, buffer, 1); + } + if (ecl_read_byte8(stream, buffer+1, nbytes) < nbytes) + return EOF; + for (i = 1; i <= nbytes; i++) { + unsigned char c = buffer[i]; + /*printf(": %04x :", c);*/ + unlikely_if ((c & 0xC0) != 0x80) + return decoding_error(stream, buffer, nbytes+1); + cum = (cum << 6) | (c & 0x3F); + unlikely_if (cum == 0) + return decoding_error(stream, buffer, nbytes+1); + } + if (cum >= 0xd800) { + unlikely_if (cum <= 0xdfff) + return decoding_error(stream, buffer, nbytes+1); + unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) + return decoding_error(stream, buffer, nbytes+1); + } + /*printf("; %04x ;", cum);*/ + return cum; } static int utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c) { - int nbytes; - if (c < 0) { - nbytes = 0; - } else if (c <= 0x7F) { - buffer[0] = c; - nbytes = 1; - } else if (c <= 0x7ff) { - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xC0; - /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ - nbytes = 2; - } else if (c <= 0xFFFF) { - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xE0; - nbytes = 3; - } else if (c <= 0x1FFFFFL) { - buffer[3] = (c & 0x3f) | 0x80; c >>= 6; - buffer[2] = (c & 0x3f) | 0x80; c >>= 6; - buffer[1] = (c & 0x3f) | 0x80; c >>= 6; - buffer[0] = c | 0xF0; - nbytes = 4; - } - return nbytes; + int nbytes; + if (c < 0) { + nbytes = 0; + } else if (c <= 0x7F) { + buffer[0] = c; + nbytes = 1; + } else if (c <= 0x7ff) { + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xC0; + /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ + nbytes = 2; + } else if (c <= 0xFFFF) { + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xE0; + nbytes = 3; + } else if (c <= 0x1FFFFFL) { + buffer[3] = (c & 0x3f) | 0x80; c >>= 6; + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xF0; + nbytes = 4; + } + return nbytes; } #endif @@ -1137,136 +1137,136 @@ utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c) static cl_index clos_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (!ECL_FIXNUMP(byte)) - break; - c[i] = ecl_fixnum(byte); - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (!ECL_FIXNUMP(byte)) + break; + c[i] = ecl_fixnum(byte); + } + return i; } static cl_index clos_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index i; - for (i = 0; i < n; i++) { - cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, - ecl_make_fixnum(c[i])); - if (!ECL_FIXNUMP(byte)) - break; - } - return i; + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm, + ecl_make_fixnum(c[i])); + if (!ECL_FIXNUMP(byte)) + break; + } + return i; } static cl_object clos_stream_read_byte(cl_object strm) { - cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); - if (b == @':eof') b = ECL_NIL; - return b; + cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm); + if (b == @':eof') b = ECL_NIL; + return b; } static void clos_stream_write_byte(cl_object c, cl_object strm) { - _ecl_funcall3(@'gray::stream-write-byte', strm, c); + _ecl_funcall3(@'gray::stream-write-byte', strm, c); } static ecl_character clos_stream_read_char(cl_object strm) { - cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); - cl_fixnum value; - if (ECL_CHARACTERP(output)) - value = ECL_CHAR_CODE(output); - else if (ECL_FIXNUMP(output)) - value = ecl_fixnum(output); - else if (output == ECL_NIL || output == @':eof') - return EOF; - else - value = -1; - unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) - FEerror("Unknown character ~A", 1, output); - return value; + cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm); + cl_fixnum value; + if (ECL_CHARACTERP(output)) + value = ECL_CHAR_CODE(output); + else if (ECL_FIXNUMP(output)) + value = ecl_fixnum(output); + else if (output == ECL_NIL || output == @':eof') + return EOF; + else + value = -1; + unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT) + FEerror("Unknown character ~A", 1, output); + return value; } static ecl_character clos_stream_write_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); - return c; + _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c)); + return c; } static void clos_stream_unread_char(cl_object strm, ecl_character c) { - _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); + _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c)); } static int clos_stream_peek_char(cl_object strm) { - cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); - if (out == @':eof') return EOF; - return ecl_char_code(out); + cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm); + if (out == @':eof') return EOF; + return ecl_char_code(out); } static int clos_stream_listen(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); + return !Null(_ecl_funcall2(@'gray::stream-listen', strm)); } static void clos_stream_clear_input(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-input', strm); + _ecl_funcall2(@'gray::stream-clear-input', strm); } static void clos_stream_clear_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-clear-output', strm); - return; + _ecl_funcall2(@'gray::stream-clear-output', strm); + return; } static void clos_stream_force_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-force-output', strm); + _ecl_funcall2(@'gray::stream-force-output', strm); } static void clos_stream_finish_output(cl_object strm) { - _ecl_funcall2(@'gray::stream-finish-output', strm); + _ecl_funcall2(@'gray::stream-finish-output', strm); } static int clos_stream_input_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::input-stream-p', strm)); } static int clos_stream_output_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); + return !Null(_ecl_funcall2(@'gray::output-stream-p', strm)); } static int clos_stream_interactive_p(cl_object strm) { - return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); + return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm)); } static cl_object clos_stream_element_type(cl_object strm) { - return _ecl_funcall2(@'gray::stream-element-type', strm); + return _ecl_funcall2(@'gray::stream-element-type', strm); } #define clos_stream_length not_a_file_stream @@ -1274,62 +1274,62 @@ clos_stream_element_type(cl_object strm) static cl_object clos_stream_get_position(cl_object strm) { - return _ecl_funcall2(@'gray::stream-file-position', strm); + return _ecl_funcall2(@'gray::stream-file-position', strm); } static cl_object clos_stream_set_position(cl_object strm, cl_object pos) { - return _ecl_funcall3(@'gray::stream-file-position', strm, pos); + return _ecl_funcall3(@'gray::stream-file-position', strm, pos); } static int clos_stream_column(cl_object strm) { - cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); - /* FIXME! The Gray streams specifies NIL is a valid - * value but means "unknown". Should we make it - * zero? */ - return Null(col)? 0 : ecl_to_size(col); + cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm); + /* FIXME! The Gray streams specifies NIL is a valid + * value but means "unknown". Should we make it + * zero? */ + return Null(col)? 0 : ecl_to_size(col); } static cl_object clos_stream_close(cl_object strm) { - return _ecl_funcall2(@'gray::close', strm); + return _ecl_funcall2(@'gray::close', strm); } const struct ecl_file_ops clos_stream_ops = { - clos_stream_write_byte8, - clos_stream_read_byte8, + clos_stream_write_byte8, + clos_stream_read_byte8, - clos_stream_write_byte, - clos_stream_read_byte, + clos_stream_write_byte, + clos_stream_read_byte, - clos_stream_read_char, - clos_stream_write_char, - clos_stream_unread_char, - clos_stream_peek_char, + clos_stream_read_char, + clos_stream_write_char, + clos_stream_unread_char, + clos_stream_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - clos_stream_listen, - clos_stream_clear_input, - clos_stream_clear_output, - clos_stream_finish_output, - clos_stream_force_output, + clos_stream_listen, + clos_stream_clear_input, + clos_stream_clear_output, + clos_stream_finish_output, + clos_stream_force_output, - clos_stream_input_p, - clos_stream_output_p, - clos_stream_interactive_p, - clos_stream_element_type, + clos_stream_input_p, + clos_stream_output_p, + clos_stream_interactive_p, + clos_stream_element_type, - clos_stream_length, - clos_stream_get_position, - clos_stream_set_position, - clos_stream_column, - clos_stream_close + clos_stream_length, + clos_stream_get_position, + clos_stream_set_position, + clos_stream_column, + clos_stream_close }; #endif /* ECL_CLOS_STREAMS */ @@ -1340,165 +1340,165 @@ const struct ecl_file_ops clos_stream_ops = { static ecl_character str_out_write_char(cl_object strm, ecl_character c) { - int column = strm->stream.column; - if (c == '\n') - strm->stream.column = 0; - else if (c == '\t') - strm->stream.column = (column&~(cl_index)7) + 8; - else - strm->stream.column++; - ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); - return c; + int column = strm->stream.column; + if (c == '\n') + strm->stream.column = 0; + else if (c == '\t') + strm->stream.column = (column&~(cl_index)7) + 8; + else + strm->stream.column++; + ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); + return c; } static cl_object str_out_element_type(cl_object strm) { - cl_object string = STRING_OUTPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_OUTPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); + return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); } static cl_object str_out_set_position(cl_object strm, cl_object pos) { - cl_object string = STRING_OUTPUT_STRING(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = strm->base_string.dim; - } else { - disp = ecl_to_size(pos); - } - if (disp < string->base_string.fillp) { - string->base_string.fillp = disp; - } else { - disp -= string->base_string.fillp; - while (disp-- > 0) - ecl_write_char(' ', strm); - } - return ECL_T; + cl_object string = STRING_OUTPUT_STRING(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = strm->base_string.dim; + } else { + disp = ecl_to_size(pos); + } + if (disp < string->base_string.fillp) { + string->base_string.fillp = disp; + } else { + disp -= string->base_string.fillp; + while (disp-- > 0) + ecl_write_char(' ', strm); + } + return ECL_T; } static int str_out_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } const struct ecl_file_ops str_out_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_binary_write_byte, - not_input_read_byte, + not_binary_write_byte, + not_input_read_byte, - not_input_read_char, - str_out_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + str_out_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - str_out_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + str_out_element_type, - not_a_file_stream, /* length */ - str_out_get_position, - str_out_set_position, - str_out_column, - generic_close + not_a_file_stream, /* length */ + str_out_get_position, + str_out_set_position, + str_out_column, + generic_close }; cl_object si_make_string_output_stream_from_string(cl_object s) { - cl_object strm = alloc_stream(); - unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) - FEerror("~S is not a -string with a fill-pointer.", 1, s); - strm->stream.ops = duplicate_dispatch_table(&str_out_ops); - strm->stream.mode = (short)ecl_smm_string_output; - STRING_OUTPUT_STRING(strm) = s; - strm->stream.column = 0; + cl_object strm = alloc_stream(); + unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s)) + FEerror("~S is not a -string with a fill-pointer.", 1, s); + strm->stream.ops = duplicate_dispatch_table(&str_out_ops); + strm->stream.mode = (short)ecl_smm_string_output; + STRING_OUTPUT_STRING(strm) = s; + strm->stream.column = 0; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(s)) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(s)) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - @(return strm) + @(return strm) } cl_object ecl_make_string_output_stream(cl_index line_length, int extended) { #ifdef ECL_UNICODE - cl_object s = extended? - ecl_alloc_adjustable_extended_string(line_length) : - ecl_alloc_adjustable_base_string(line_length); + cl_object s = extended? + ecl_alloc_adjustable_extended_string(line_length) : + ecl_alloc_adjustable_base_string(line_length); #else - cl_object s = ecl_alloc_adjustable_base_string(line_length); + cl_object s = ecl_alloc_adjustable_base_string(line_length); #endif - return si_make_string_output_stream_from_string(s); + return si_make_string_output_stream_from_string(s); } @(defun make-string-output-stream (&key (element_type @'character')) - int extended = 0; + int extended = 0; @ - if (element_type == @'base-char') { - (void)0; - } else if (element_type == @'character') { + if (element_type == @'base-char') { + (void)0; + } else if (element_type == @'character') { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { - (void)0; - } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) { + (void)0; + } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) { #ifdef ECL_UNICODE - extended = 1; + extended = 1; #endif - } else { - FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", - 1, element_type); - } - @(return ecl_make_string_output_stream(128, extended)) + } else { + FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", + 1, element_type); + } + @(return ecl_make_string_output_stream(128, extended)) @) cl_object cl_get_output_stream_string(cl_object strm) { - cl_object strng; - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) - FEwrong_type_only_arg(@[get-output-stream-string], - strm, @[string-stream]); - strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); - STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; - @(return strng) + cl_object strng; + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output)) + FEwrong_type_only_arg(@[get-output-stream-string], + strm, @[string-stream]); + strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); + STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; + @(return strng) } /********************************************************************** @@ -1508,146 +1508,146 @@ cl_get_output_stream_string(cl_object strm) static ecl_character str_in_read_char(cl_object strm) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - ecl_character c; - if (curr_pos >= STRING_INPUT_LIMIT(strm)) { - c = EOF; - } else { - c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); - STRING_INPUT_POSITION(strm) = curr_pos+1; - } - return c; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + ecl_character c; + if (curr_pos >= STRING_INPUT_LIMIT(strm)) { + c = EOF; + } else { + c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); + STRING_INPUT_POSITION(strm) = curr_pos+1; + } + return c; } static void str_in_unread_char(cl_object strm, ecl_character c) { - cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); - unlikely_if (c <= 0) { - unread_error(strm); - } - STRING_INPUT_POSITION(strm) = curr_pos - 1; + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + unlikely_if (c <= 0) { + unread_error(strm); + } + STRING_INPUT_POSITION(strm) = curr_pos - 1; } static ecl_character str_in_peek_char(cl_object strm) { - cl_index pos = STRING_INPUT_POSITION(strm); - if (pos >= STRING_INPUT_LIMIT(strm)) { - return EOF; - } else { - return ecl_char(STRING_INPUT_STRING(strm), pos); - } + cl_index pos = STRING_INPUT_POSITION(strm); + if (pos >= STRING_INPUT_LIMIT(strm)) { + return EOF; + } else { + return ecl_char(STRING_INPUT_STRING(strm), pos); + } } static int str_in_listen(cl_object strm) { - if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object str_in_element_type(cl_object strm) { - cl_object string = STRING_INPUT_STRING(strm); - if (ECL_BASE_STRING_P(string)) - return @'base-char'; - return @'character'; + cl_object string = STRING_INPUT_STRING(strm); + if (ECL_BASE_STRING_P(string)) + return @'base-char'; + return @'character'; } static cl_object str_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); } static cl_object str_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = STRING_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= STRING_INPUT_LIMIT(strm)) { - disp = STRING_INPUT_LIMIT(strm); - } - } - STRING_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = STRING_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= STRING_INPUT_LIMIT(strm)) { + disp = STRING_INPUT_LIMIT(strm); + } + } + STRING_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops str_in_ops = { - not_output_write_byte8, - not_binary_read_byte8, + not_output_write_byte8, + not_binary_read_byte8, - not_output_write_byte, - not_binary_read_byte, + not_output_write_byte, + not_binary_read_byte, - str_in_read_char, - not_output_write_char, - str_in_unread_char, - str_in_peek_char, + str_in_read_char, + not_output_write_char, + str_in_unread_char, + str_in_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - str_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + str_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - str_in_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + str_in_element_type, - not_a_file_stream, /* length */ - str_in_get_position, - str_in_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + str_in_get_position, + str_in_set_position, + generic_column, + generic_close }; cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) { - cl_object strm; + cl_object strm; - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&str_in_ops); - strm->stream.mode = (short)ecl_smm_string_input; - STRING_INPUT_STRING(strm) = strng; - STRING_INPUT_POSITION(strm) = istart; - STRING_INPUT_LIMIT(strm) = iend; + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&str_in_ops); + strm->stream.mode = (short)ecl_smm_string_input; + STRING_INPUT_STRING(strm) = strng; + STRING_INPUT_POSITION(strm) = istart; + STRING_INPUT_LIMIT(strm) = iend; #if !defined(ECL_UNICODE) - strm->stream.format = @':pass-through'; - strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; - strm->stream.byte_size = 8; + strm->stream.format = @':pass-through'; + strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT; + strm->stream.byte_size = 8; #else - if (ECL_BASE_STRING_P(strng) == t_base_string) { - strm->stream.format = @':latin-1'; - strm->stream.flags = ECL_STREAM_LATIN_1; - strm->stream.byte_size = 8; - } else { - strm->stream.format = @':ucs-4'; - strm->stream.flags = ECL_STREAM_UCS_4; - strm->stream.byte_size = 32; - } + if (ECL_BASE_STRING_P(strng) == t_base_string) { + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + } else { + strm->stream.format = @':ucs-4'; + strm->stream.flags = ECL_STREAM_UCS_4; + strm->stream.byte_size = 32; + } #endif - return strm; + return strm; } @(defun make_string_input_stream (strng &o (istart ecl_make_fixnum(0)) iend) - cl_index_pair p; + cl_index_pair p; @ - strng = cl_string(strng); - p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); - @(return (ecl_make_string_input_stream(strng, p.start, p.end))) + strng = cl_string(strng); + p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend); + @(return (ecl_make_string_input_stream(strng, p.start, p.end))) @) /********************************************************************** @@ -1657,192 +1657,192 @@ ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) static cl_index two_way_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - if (strm == cl_core.terminal_io) - ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); - return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); + if (strm == cl_core.terminal_io) + ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); + return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); } static cl_index two_way_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); } static void two_way_write_byte(cl_object byte, cl_object stream) { - ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); + ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(stream)); } static cl_object two_way_read_byte(cl_object stream) { - return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); + return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream)); } static ecl_character two_way_read_char(cl_object strm) { - return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); + ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); } static ecl_character two_way_peek_char(cl_object strm) { - return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); + return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); } static cl_index two_way_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_INPUT(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_INPUT(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index two_way_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = TWO_WAY_STREAM_OUTPUT(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = TWO_WAY_STREAM_OUTPUT(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int two_way_listen(cl_object strm) { - return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); + return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_input(cl_object strm) { - ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); + ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); } static void two_way_clear_output(cl_object strm) { - ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_force_output(cl_object strm) { - ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); } static void two_way_finish_output(cl_object strm) { - ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); + ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); } static int two_way_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); + return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); } static cl_object two_way_element_type(cl_object strm) { - return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); + return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); } static int two_way_column(cl_object strm) { - return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); + return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); } static cl_object two_way_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, TWO_WAY_STREAM_INPUT(strm)); - cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, TWO_WAY_STREAM_INPUT(strm)); + cl_close(1, TWO_WAY_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops two_way_ops = { - two_way_write_byte8, - two_way_read_byte8, + two_way_write_byte8, + two_way_read_byte8, - two_way_write_byte, - two_way_read_byte, + two_way_write_byte, + two_way_read_byte, - two_way_read_char, - two_way_write_char, - two_way_unread_char, - two_way_peek_char, + two_way_read_char, + two_way_write_char, + two_way_unread_char, + two_way_peek_char, - two_way_read_vector, - two_way_write_vector, + two_way_read_vector, + two_way_write_vector, - two_way_listen, - two_way_clear_input, - two_way_clear_output, - two_way_finish_output, - two_way_force_output, + two_way_listen, + two_way_clear_input, + two_way_clear_output, + two_way_finish_output, + two_way_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - two_way_interactive_p, - two_way_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + two_way_interactive_p, + two_way_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - two_way_column, - two_way_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + two_way_column, + two_way_close }; cl_object cl_make_two_way_stream(cl_object istrm, cl_object ostrm) { - cl_object strm; - if (!ecl_input_stream_p(istrm)) - not_an_input_stream(istrm); - if (!ecl_output_stream_p(ostrm)) - not_an_output_stream(ostrm); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(istrm); - strm->stream.mode = (short)ecl_smm_two_way; - strm->stream.ops = duplicate_dispatch_table(&two_way_ops); - TWO_WAY_STREAM_INPUT(strm) = istrm; - TWO_WAY_STREAM_OUTPUT(strm) = ostrm; - @(return strm) + cl_object strm; + if (!ecl_input_stream_p(istrm)) + not_an_input_stream(istrm); + if (!ecl_output_stream_p(ostrm)) + not_an_output_stream(ostrm); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(istrm); + strm->stream.mode = (short)ecl_smm_two_way; + strm->stream.ops = duplicate_dispatch_table(&two_way_ops); + TWO_WAY_STREAM_INPUT(strm) = istrm; + TWO_WAY_STREAM_OUTPUT(strm) = ostrm; + @(return strm) } cl_object cl_two_way_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-input-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_INPUT(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-input-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_INPUT(strm)); } cl_object cl_two_way_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) - FEwrong_type_only_arg(@[two-way-stream-output-stream], - strm, @[two-way-stream]); - @(return TWO_WAY_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way)) + FEwrong_type_only_arg(@[two-way-stream-output-stream], + strm, @[two-way-stream]); + @(return TWO_WAY_STREAM_OUTPUT(strm)) } /********************************************************************** @@ -1852,173 +1852,173 @@ cl_two_way_stream_output_stream(cl_object strm) static cl_index broadcast_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l; - cl_index out = n; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); - } - return out; + cl_object l; + cl_index out = n; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); + } + return out; } static ecl_character broadcast_write_char(cl_object strm, ecl_character c) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_char(c, ECL_CONS_CAR(l)); - } - return c; + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_char(c, ECL_CONS_CAR(l)); + } + return c; } static void broadcast_write_byte(cl_object c, cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_write_byte(c, ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_write_byte(c, ECL_CONS_CAR(l)); + } } static void broadcast_clear_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_clear_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_clear_output(ECL_CONS_CAR(l)); + } } static void broadcast_force_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_force_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_force_output(ECL_CONS_CAR(l)); + } } static void broadcast_finish_output(cl_object strm) { - cl_object l; - for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { - ecl_finish_output(ECL_CONS_CAR(l)); - } + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) { + ecl_finish_output(ECL_CONS_CAR(l)); + } } static cl_object broadcast_element_type(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_T; - return ecl_stream_element_type(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_T; + return ecl_stream_element_type(ECL_CONS_CAR(l)); } static cl_object broadcast_length(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_length(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_length(ECL_CONS_CAR(l)); } static cl_object broadcast_get_position(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ecl_make_fixnum(0); - return ecl_file_position(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ecl_make_fixnum(0); + return ecl_file_position(ECL_CONS_CAR(l)); } static cl_object broadcast_set_position(cl_object strm, cl_object pos) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return ECL_NIL; - return ecl_file_position_set(ECL_CONS_CAR(l), pos); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return ECL_NIL; + return ecl_file_position_set(ECL_CONS_CAR(l), pos); } static int broadcast_column(cl_object strm) { - cl_object l = BROADCAST_STREAM_LIST(strm); - if (Null(l)) - return 0; - return ecl_file_column(ECL_CONS_CAR(l)); + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return 0; + return ecl_file_column(ECL_CONS_CAR(l)); } static cl_object broadcast_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops broadcast_ops = { - broadcast_write_byte8, - not_input_read_byte8, + broadcast_write_byte8, + not_input_read_byte8, - broadcast_write_byte, - not_input_read_byte, + broadcast_write_byte, + not_input_read_byte, - not_input_read_char, - broadcast_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + broadcast_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ - broadcast_clear_output, - broadcast_finish_output, - broadcast_force_output, + not_input_listen, + broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */ + broadcast_clear_output, + broadcast_finish_output, + broadcast_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - broadcast_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + broadcast_element_type, - broadcast_length, - broadcast_get_position, - broadcast_set_position, - broadcast_column, - broadcast_close + broadcast_length, + broadcast_get_position, + broadcast_set_position, + broadcast_column, + broadcast_close }; @(defun make_broadcast_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_output_stream_p(x)) - not_an_output_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - x->stream.format = @':default'; - x->stream.ops = duplicate_dispatch_table(&broadcast_ops); - x->stream.mode = (short)ecl_smm_broadcast; - BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_output_stream_p(x)) + not_an_output_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + x->stream.format = @':default'; + x->stream.ops = duplicate_dispatch_table(&broadcast_ops); + x->stream.mode = (short)ecl_smm_broadcast; + BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); + @(return x) @) cl_object cl_broadcast_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) - FEwrong_type_only_arg(@[broadcast-stream-streams], - strm, @[broadcast-stream]); - return cl_copy_list(BROADCAST_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast)) + FEwrong_type_only_arg(@[broadcast-stream-streams], + strm, @[broadcast-stream]); + return cl_copy_list(BROADCAST_STREAM_LIST(strm)); } /********************************************************************** @@ -2028,189 +2028,189 @@ cl_broadcast_stream_streams(cl_object strm) static cl_index echo_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); + cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); } static cl_index echo_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); } static void echo_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); + ecl_write_byte(c, ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_read_byte(cl_object strm) { - cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); - if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); - return out; + cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm)); + if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm)); + return out; } static ecl_character echo_read_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_read_char(ECHO_STREAM_INPUT(strm)); - if (c != EOF) - ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); - } else { - strm->stream.last_code[0] = EOF; - ecl_read_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_read_char(ECHO_STREAM_INPUT(strm)); + if (c != EOF) + ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + } else { + strm->stream.last_code[0] = EOF; + ecl_read_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static ecl_character echo_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); } static void echo_unread_char(cl_object strm, ecl_character c) { - unlikely_if (strm->stream.last_code[0] != EOF) { - unread_twice(strm); - } - strm->stream.last_code[0] = c; - ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); + unlikely_if (strm->stream.last_code[0] != EOF) { + unread_twice(strm); + } + strm->stream.last_code[0] = c; + ecl_unread_char(c, ECHO_STREAM_INPUT(strm)); } static ecl_character echo_peek_char(cl_object strm) { - ecl_character c = strm->stream.last_code[0]; - if (c == EOF) { - c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); - } - return c; + ecl_character c = strm->stream.last_code[0]; + if (c == EOF) { + c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); + } + return c; } static int echo_listen(cl_object strm) { - return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); + return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); } static void echo_clear_input(cl_object strm) { - ecl_clear_input(ECHO_STREAM_INPUT(strm)); + ecl_clear_input(ECHO_STREAM_INPUT(strm)); } static void echo_clear_output(cl_object strm) { - ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); + ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_force_output(cl_object strm) { - ecl_force_output(ECHO_STREAM_OUTPUT(strm)); + ecl_force_output(ECHO_STREAM_OUTPUT(strm)); } static void echo_finish_output(cl_object strm) { - ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); + ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_element_type(cl_object strm) { - return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); + return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); } static int echo_column(cl_object strm) { - return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); + return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); } static cl_object echo_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_close(1, ECHO_STREAM_INPUT(strm)); - cl_close(1, ECHO_STREAM_OUTPUT(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_close(1, ECHO_STREAM_INPUT(strm)); + cl_close(1, ECHO_STREAM_OUTPUT(strm)); + } + return generic_close(strm); } const struct ecl_file_ops echo_ops = { - echo_write_byte8, - echo_read_byte8, + echo_write_byte8, + echo_read_byte8, - echo_write_byte, - echo_read_byte, + echo_write_byte, + echo_read_byte, - echo_read_char, - echo_write_char, - echo_unread_char, - echo_peek_char, + echo_read_char, + echo_write_char, + echo_unread_char, + echo_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - echo_listen, - echo_clear_input, - echo_clear_output, - echo_finish_output, - echo_force_output, + echo_listen, + echo_clear_input, + echo_clear_output, + echo_finish_output, + echo_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - echo_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + echo_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - echo_column, - echo_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + echo_column, + echo_close }; cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2) { - cl_object strm; - unlikely_if (!ecl_input_stream_p(strm1)) - not_an_input_stream(strm1); - unlikely_if (!ecl_output_stream_p(strm2)) - not_an_output_stream(strm2); - strm = alloc_stream(); - strm->stream.format = cl_stream_external_format(strm1); - strm->stream.mode = (short)ecl_smm_echo; - strm->stream.ops = duplicate_dispatch_table(&echo_ops); - ECHO_STREAM_INPUT(strm) = strm1; - ECHO_STREAM_OUTPUT(strm) = strm2; - @(return strm) + cl_object strm; + unlikely_if (!ecl_input_stream_p(strm1)) + not_an_input_stream(strm1); + unlikely_if (!ecl_output_stream_p(strm2)) + not_an_output_stream(strm2); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(strm1); + strm->stream.mode = (short)ecl_smm_echo; + strm->stream.ops = duplicate_dispatch_table(&echo_ops); + ECHO_STREAM_INPUT(strm) = strm1; + ECHO_STREAM_OUTPUT(strm) = strm2; + @(return strm) } cl_object cl_echo_stream_input_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-input-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_INPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-input-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_INPUT(strm)) } cl_object cl_echo_stream_output_stream(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) - FEwrong_type_only_arg(@[echo-stream-output-stream], - strm, @[echo-stream]); - @(return ECHO_STREAM_OUTPUT(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo)) + FEwrong_type_only_arg(@[echo-stream-output-stream], + strm, @[echo-stream]); + @(return ECHO_STREAM_OUTPUT(strm)) } /********************************************************************** @@ -2220,140 +2220,140 @@ cl_echo_stream_output_stream(cl_object strm) static cl_index concatenated_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_index out = 0; - while (out < n && !Null(l)) { - cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); - out += delta; - if (out == n) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return out; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_index out = 0; + while (out < n && !Null(l)) { + cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); + out += delta; + if (out == n) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return out; } static cl_object concatenated_read_byte(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - cl_object c = ECL_NIL; - while (!Null(l)) { - c = ecl_read_byte(ECL_CONS_CAR(l)); - if (c != ECL_NIL) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_object c = ECL_NIL; + while (!Null(l)) { + c = ecl_read_byte(ECL_CONS_CAR(l)); + if (c != ECL_NIL) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static ecl_character concatenated_read_char(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - ecl_character c = EOF; - while (!Null(l)) { - c = ecl_read_char(ECL_CONS_CAR(l)); - if (c != EOF) break; - CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); - } - return c; + cl_object l = CONCATENATED_STREAM_LIST(strm); + ecl_character c = EOF; + while (!Null(l)) { + c = ecl_read_char(ECL_CONS_CAR(l)); + if (c != EOF) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; } static void concatenated_unread_char(cl_object strm, ecl_character c) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - unlikely_if (Null(l)) - unread_error(strm); - ecl_unread_char(c, ECL_CONS_CAR(l)); + cl_object l = CONCATENATED_STREAM_LIST(strm); + unlikely_if (Null(l)) + unread_error(strm); + ecl_unread_char(c, ECL_CONS_CAR(l)); } static int concatenated_listen(cl_object strm) { - cl_object l = CONCATENATED_STREAM_LIST(strm); - while (!Null(l)) { - int f = ecl_listen_stream(ECL_CONS_CAR(l)); - l = ECL_CONS_CDR(l); - if (f == ECL_LISTEN_EOF) { - CONCATENATED_STREAM_LIST(strm) = l; - } else { - return f; - } - } - return ECL_LISTEN_EOF; + cl_object l = CONCATENATED_STREAM_LIST(strm); + while (!Null(l)) { + int f = ecl_listen_stream(ECL_CONS_CAR(l)); + l = ECL_CONS_CDR(l); + if (f == ECL_LISTEN_EOF) { + CONCATENATED_STREAM_LIST(strm) = l; + } else { + return f; + } + } + return ECL_LISTEN_EOF; } static cl_object concatenated_close(cl_object strm) { - if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { - cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); - } - return generic_close(strm); + if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) { + cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm)); + } + return generic_close(strm); } const struct ecl_file_ops concatenated_ops = { - not_output_write_byte8, - concatenated_read_byte8, + not_output_write_byte8, + concatenated_read_byte8, - not_output_write_byte, - concatenated_read_byte, + not_output_write_byte, + concatenated_read_byte, - concatenated_read_char, - not_output_write_char, - concatenated_unread_char, - generic_peek_char, + concatenated_read_char, + not_output_write_char, + concatenated_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - concatenated_listen, - generic_void, /* clear_input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + concatenated_listen, + generic_void, /* clear_input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - broadcast_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + broadcast_element_type, - not_a_file_stream, /* length */ - generic_always_nil, /* get_position */ - generic_set_position, - generic_column, - concatenated_close + not_a_file_stream, /* length */ + generic_always_nil, /* get_position */ + generic_set_position, + generic_column, + concatenated_close }; @(defun make_concatenated_stream (&rest ap) - cl_object x, streams; - int i; + cl_object x, streams; + int i; @ - streams = ECL_NIL; - for (i = 0; i < narg; i++) { - x = ecl_va_arg(ap); - unlikely_if (!ecl_input_stream_p(x)) - not_an_input_stream(x); - streams = CONS(x, streams); - } - x = alloc_stream(); - if (Null(streams)) { - x->stream.format = @':pass-through'; - } else { - x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); - } - x->stream.mode = (short)ecl_smm_concatenated; - x->stream.ops = duplicate_dispatch_table(&concatenated_ops); - CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); - @(return x) + streams = ECL_NIL; + for (i = 0; i < narg; i++) { + x = ecl_va_arg(ap); + unlikely_if (!ecl_input_stream_p(x)) + not_an_input_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + if (Null(streams)) { + x->stream.format = @':pass-through'; + } else { + x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); + } + x->stream.mode = (short)ecl_smm_concatenated; + x->stream.ops = duplicate_dispatch_table(&concatenated_ops); + CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); + @(return x) @) cl_object cl_concatenated_stream_streams(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) - FEwrong_type_only_arg(@[concatenated-stream-streams], - strm, @[concatenated-stream]); - return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated)) + FEwrong_type_only_arg(@[concatenated-stream-streams], + strm, @[concatenated-stream]); + return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); } /********************************************************************** @@ -2363,196 +2363,196 @@ cl_concatenated_stream_streams(cl_object strm) static cl_index synonym_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static cl_index synonym_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); + return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); } static void synonym_write_byte(cl_object c, cl_object strm) { - ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); + ecl_write_byte(c, SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_read_byte(cl_object strm) { - return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_byte(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_read_char(cl_object strm) { - return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_write_char(cl_object strm, ecl_character c) { - return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); + return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); } static void synonym_unread_char(cl_object strm, ecl_character c) { - ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); + ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); } static ecl_character synonym_peek_char(cl_object strm) { - return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); + return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); } static cl_index synonym_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->read_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); } static cl_index synonym_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) { - strm = SYNONYM_STREAM_STREAM(strm); - return stream_dispatch_table(strm)->write_vector(strm, data, start, n); + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); } static int synonym_listen(cl_object strm) { - return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); + return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_input(cl_object strm) { - ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); } static void synonym_clear_output(cl_object strm) { - ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); + ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_force_output(cl_object strm) { - ecl_force_output(SYNONYM_STREAM_STREAM(strm)); + ecl_force_output(SYNONYM_STREAM_STREAM(strm)); } static void synonym_finish_output(cl_object strm) { - ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); + ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); } static int synonym_input_p(cl_object strm) { - return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_output_p(cl_object strm) { - return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); } static int synonym_interactive_p(cl_object strm) { - return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); + return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_element_type(cl_object strm) { - return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); + return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_length(cl_object strm) { - return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_get_position(cl_object strm) { - return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); } static cl_object synonym_set_position(cl_object strm, cl_object pos) { - return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); + return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); } static int synonym_column(cl_object strm) { - return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); + return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); } const struct ecl_file_ops synonym_ops = { - synonym_write_byte8, - synonym_read_byte8, + synonym_write_byte8, + synonym_read_byte8, - synonym_write_byte, - synonym_read_byte, + synonym_write_byte, + synonym_read_byte, - synonym_read_char, - synonym_write_char, - synonym_unread_char, - synonym_peek_char, + synonym_read_char, + synonym_write_char, + synonym_unread_char, + synonym_peek_char, - synonym_read_vector, - synonym_write_vector, + synonym_read_vector, + synonym_write_vector, - synonym_listen, - synonym_clear_input, - synonym_clear_output, - synonym_finish_output, - synonym_force_output, + synonym_listen, + synonym_clear_input, + synonym_clear_output, + synonym_finish_output, + synonym_force_output, - synonym_input_p, - synonym_output_p, - synonym_interactive_p, - synonym_element_type, + synonym_input_p, + synonym_output_p, + synonym_interactive_p, + synonym_element_type, - synonym_length, - synonym_get_position, - synonym_set_position, - synonym_column, - generic_close + synonym_length, + synonym_get_position, + synonym_set_position, + synonym_column, + generic_close }; cl_object cl_make_synonym_stream(cl_object sym) { - cl_object x; + cl_object x; - sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); - x = alloc_stream(); - x->stream.ops = duplicate_dispatch_table(&synonym_ops); - x->stream.mode = (short)ecl_smm_synonym; - SYNONYM_STREAM_SYMBOL(x) = sym; - @(return x) + sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); + x = alloc_stream(); + x->stream.ops = duplicate_dispatch_table(&synonym_ops); + x->stream.mode = (short)ecl_smm_synonym; + SYNONYM_STREAM_SYMBOL(x) = sym; + @(return x) } cl_object cl_synonym_stream_symbol(cl_object strm) { - unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) - FEwrong_type_only_arg(@[synonym-stream-symbol], - strm, @[synonym-stream]); - @(return SYNONYM_STREAM_SYMBOL(strm)) + unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym)) + FEwrong_type_only_arg(@[synonym-stream-symbol], + strm, @[synonym-stream]); + @(return SYNONYM_STREAM_SYMBOL(strm)) } /********************************************************************** @@ -2568,56 +2568,56 @@ cl_synonym_stream_symbol(cl_object strm) static int safe_open(const char *filename, int flags, ecl_mode_t mode) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = open(filename, flags, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = open(filename, flags, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_close(int f) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = close(f); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = close(f); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fopen(const char *filename, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fopen(filename, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fopen(filename, mode); + ecl_enable_interrupts_env(the_env); + return output; } static FILE * safe_fdopen(int fildes, const char *mode) { - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fdopen(fildes, mode); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + FILE *output; + ecl_disable_interrupts_env(the_env); + output = fdopen(fildes, mode); + ecl_enable_interrupts_env(the_env); + return output; } static int safe_fclose(FILE *stream) { - const cl_env_ptr the_env = ecl_process_env(); - int output; - ecl_disable_interrupts_env(the_env); - output = fclose(stream); - ecl_enable_interrupts_env(the_env); - return output; + const cl_env_ptr the_env = ecl_process_env(); + int output; + ecl_disable_interrupts_env(the_env); + output = fclose(stream); + ecl_enable_interrupts_env(the_env); + return output; } /********************************************************************** @@ -2627,96 +2627,96 @@ safe_fclose(FILE *stream) static cl_index consume_byte_stack(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - while (n) { - cl_object l = strm->stream.byte_stack; - if (l == ECL_NIL) - return out + strm->stream.ops->read_byte8(strm, c, n); - *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); - out++; - n--; - strm->stream.byte_stack = l = ECL_CONS_CDR(l); - } - return out; + cl_index out = 0; + while (n) { + cl_object l = strm->stream.byte_stack; + if (l == ECL_NIL) + return out + strm->stream.ops->read_byte8(strm, c, n); + *(c++) = ecl_fixnum(ECL_CONS_CAR(l)); + out++; + n--; + strm->stream.byte_stack = l = ECL_CONS_CDR(l); + } + return out; } static cl_index io_file_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); - do { - out = read(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "read")); - ecl_enable_interrupts(); - return out; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); + do { + out = read(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "read")); + ecl_enable_interrupts(); + return out; + } } static cl_index output_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_fixnum out; - ecl_disable_interrupts(); - do { - out = write(f, c, sizeof(char)*n); - } while (out < 0 && restartable_io_error(strm, "write")); - ecl_enable_interrupts(); - return out; + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out; + ecl_disable_interrupts(); + do { + out = write(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm, "write")); + ecl_enable_interrupts(); + return out; } static cl_index io_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - /* Try to move to the beginning of the unread characters */ - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - strm->stream.byte_stack = ECL_NIL; - } - return output_file_write_byte8(strm, c, n); + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + /* Try to move to the beginning of the unread characters */ + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + strm->stream.byte_stack = ECL_NIL; + } + return output_file_write_byte8(strm, c, n); } static int io_file_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { - cl_env_ptr the_env = ecl_process_env(); - int f = IO_FILE_DESCRIPTOR(strm); - ecl_off_t disp, new; - ecl_disable_interrupts_env(the_env); - disp = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts_env(the_env); - if (disp != (ecl_off_t)-1) { - ecl_disable_interrupts_env(the_env); - new = lseek(f, 0, SEEK_END); - ecl_enable_interrupts_env(the_env); - lseek(f, disp, SEEK_SET); - if (new == disp) { - return ECL_LISTEN_NO_CHAR; - } else if (new != (ecl_off_t)-1) { - return ECL_LISTEN_AVAILABLE; - } - } - } - return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { + cl_env_ptr the_env = ecl_process_env(); + int f = IO_FILE_DESCRIPTOR(strm); + ecl_off_t disp, new; + ecl_disable_interrupts_env(the_env); + disp = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts_env(the_env); + if (disp != (ecl_off_t)-1) { + ecl_disable_interrupts_env(the_env); + new = lseek(f, 0, SEEK_END); + ecl_enable_interrupts_env(the_env); + lseek(f, disp, SEEK_SET); + if (new == disp) { + return ECL_LISTEN_NO_CHAR; + } else if (new != (ecl_off_t)-1) { + return ECL_LISTEN_AVAILABLE; + } + } + } + return file_listen(strm, IO_FILE_DESCRIPTOR(strm)); } #if defined(ECL_MS_WINDOWS_HOST) static int isaconsole(int i) { - HANDLE h = (HANDLE)_get_osfhandle(i); - DWORD mode; - return !!GetConsoleMode(h, &mode); + HANDLE h = (HANDLE)_get_osfhandle(i); + DWORD mode; + return !!GetConsoleMode(h, &mode); } #define isatty isaconsole #endif @@ -2724,19 +2724,19 @@ isaconsole(int i) static void io_file_clear_input(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); + int f = IO_FILE_DESCRIPTOR(strm); #if defined(ECL_MS_WINDOWS_HOST) - if (isatty(f)) { - /* Flushes Win32 console */ - if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } + if (isatty(f)) { + /* Flushes Win32 console */ + if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } #endif - while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { - ecl_character c = eformat_read_char(strm); - if (c == EOF) return; - } + while (file_listen(strm, f) == ECL_LISTEN_AVAILABLE) { + ecl_character c = eformat_read_char(strm); + if (c == EOF) return; + } } #define io_file_clear_output generic_void @@ -2746,254 +2746,254 @@ io_file_clear_input(cl_object strm) static int io_file_interactive_p(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - return isatty(f); + int f = IO_FILE_DESCRIPTOR(strm); + return isatty(f); } static cl_object io_file_element_type(cl_object strm) { - return IO_FILE_ELT_TYPE(strm); + return IO_FILE_ELT_TYPE(strm); } static cl_object io_file_length(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - cl_object output = ecl_file_len(f); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + int f = IO_FILE_DESCRIPTOR(strm); + cl_object output = ecl_file_len(f); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_file_get_position(cl_object strm) { - cl_object output; - ecl_off_t offset; + cl_object output; + ecl_off_t offset; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); - ecl_disable_interrupts(); - offset = lseek(f, 0, SEEK_CUR); - ecl_enable_interrupts(); - unlikely_if (offset < 0) - if (errno == ESPIPE) - return(ECL_NIL); - else - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + ecl_disable_interrupts(); + offset = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts(); + unlikely_if (offset < 0) + if (errno == ESPIPE) + return(ECL_NIL); + else + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_file_set_position(cl_object strm, cl_object large_disp) { - ecl_off_t disp; - int mode; - int f = IO_FILE_DESCRIPTOR(strm); - if (isatty(f)) return(ECL_NIL); - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - disp = lseek(f, disp, mode); - return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; + ecl_off_t disp; + int mode; + int f = IO_FILE_DESCRIPTOR(strm); + if (isatty(f)) return(ECL_NIL); + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + disp = lseek(f, disp, mode); + return (disp == (ecl_off_t)-1)? ECL_NIL : ECL_T; } static int io_file_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_file_close(cl_object strm) { - int f = IO_FILE_DESCRIPTOR(strm); - int failed; - unlikely_if (f == STDOUT_FILENO) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == STDIN_FILENO) - FEerror("Cannot close the standard input", 0); - failed = safe_close(f); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = -1; - return generic_close(strm); + int f = IO_FILE_DESCRIPTOR(strm); + int failed; + unlikely_if (f == STDOUT_FILENO) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == STDIN_FILENO) + FEerror("Cannot close the standard input", 0); + failed = safe_close(f); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = -1; + return generic_close(strm); } static cl_index io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return start + strm->stream.ops->read_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->read_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_read_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return start + strm->stream.ops->read_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->read_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_read_vector(strm, data, start, end); } static cl_index io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) { - cl_elttype t = ecl_array_elttype(data); - if (start >= end) - return start; - if (t == ecl_aet_b8 || t == ecl_aet_i8) { - if (strm->stream.byte_size == 8) { - void *aux = data->vector.self.bc + start; - return strm->stream.ops->write_byte8(strm, aux, end-start); - } - } else if (t == ecl_aet_fix || t == ecl_aet_index) { - if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { - void *aux = data->vector.self.fix + start; - cl_index bytes = (end - start) * sizeof(cl_fixnum); - bytes = strm->stream.ops->write_byte8(strm, aux, bytes); - return start + bytes / sizeof(cl_fixnum); - } - } - return generic_write_vector(strm, data, start, end); + cl_elttype t = ecl_array_elttype(data); + if (start >= end) + return start; + if (t == ecl_aet_b8 || t == ecl_aet_i8) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.bc + start; + return strm->stream.ops->write_byte8(strm, aux, end-start); + } + } else if (t == ecl_aet_fix || t == ecl_aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->write_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_write_vector(strm, data, start, end); } const struct ecl_file_ops io_file_ops = { - io_file_write_byte8, - io_file_read_byte8, + io_file_write_byte8, + io_file_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - io_file_write_vector, + io_file_read_vector, + io_file_write_vector, - io_file_listen, - io_file_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, + io_file_listen, + io_file_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_file_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_file_interactive_p, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops output_file_ops = { - output_file_write_byte8, - not_input_read_byte8, + output_file_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, - generic_read_vector, - io_file_write_vector, + generic_read_vector, + io_file_write_vector, - not_input_listen, - not_input_clear_input, - io_file_clear_output, - io_file_finish_output, - io_file_force_output, + not_input_listen, + not_input_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - io_file_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close }; const struct ecl_file_ops input_file_ops = { - not_output_write_byte8, - io_file_read_byte8, + not_output_write_byte8, + io_file_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - generic_write_vector, + io_file_read_vector, + generic_write_vector, - io_file_listen, - io_file_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + io_file_listen, + io_file_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_file_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_file_interactive_p, + io_file_element_type, - io_file_length, - io_file_get_position, - io_file_set_position, - generic_column, - io_file_close + io_file_length, + io_file_get_position, + io_file_set_position, + generic_column, + io_file_close }; @@ -3003,10 +3003,10 @@ parse_external_format(cl_object stream, cl_object format, int flags) if (format == @':default') { format = ecl_symbol_value(@'ext::*default-external-format*'); } - if (CONSP(format)) { - flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); - format = ECL_CONS_CAR(format); - } + if (CONSP(format)) { + flags = parse_external_format(stream, ECL_CONS_CDR(format), flags); + format = ECL_CONS_CAR(format); + } if (format == ECL_T) { #ifdef ECL_UNICODE return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; @@ -3014,232 +3014,232 @@ parse_external_format(cl_object stream, cl_object format, int flags) return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif } - if (format == ECL_NIL) { - return flags; - } - if (format == @':CR') { - return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; - } - if (format == @':LF') { - return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; - } - if (format == @':CRLF') { - return flags | (ECL_STREAM_CR+ECL_STREAM_LF); - } - if (format == @':LITTLE-ENDIAN') { - return flags | ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':BIG-ENDIAN') { - return flags & ~ECL_STREAM_LITTLE_ENDIAN; - } - if (format == @':pass-through') { + if (format == ECL_NIL) { + return flags; + } + if (format == @':CR') { + return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF; + } + if (format == @':LF') { + return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR; + } + if (format == @':CRLF') { + return flags | (ECL_STREAM_CR+ECL_STREAM_LF); + } + if (format == @':LITTLE-ENDIAN') { + return flags | ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':BIG-ENDIAN') { + return flags & ~ECL_STREAM_LITTLE_ENDIAN; + } + if (format == @':pass-through') { #ifdef ECL_UNICODE - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; #else - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT; #endif - } + } #ifdef ECL_UNICODE PARSE_SYMBOLS: - if (format == @':UTF-8') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; - } - if (format == @':UCS-2') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; - } - if (format == @':UCS-2BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; - } - if (format == @':UCS-2LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; - } - if (format == @':UCS-4') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; - } - if (format == @':UCS-4BE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; - } - if (format == @':UCS-4LE') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; - } - if (format == @':ISO-8859-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; - } - if (format == @':LATIN-1') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; - } - if (format == @':US-ASCII') { - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; - } - if (ECL_HASH_TABLE_P(format)) { - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } - if (ECL_SYMBOLP(format)) { - format = si_make_encoding(format); - if (ECL_SYMBOLP(format)) - goto PARSE_SYMBOLS; - stream->stream.format_table = format; - return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; - } + if (format == @':UTF-8') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; + } + if (format == @':UCS-2') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2; + } + if (format == @':UCS-2BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE; + } + if (format == @':UCS-2LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE; + } + if (format == @':UCS-4') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4; + } + if (format == @':UCS-4BE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE; + } + if (format == @':UCS-4LE') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE; + } + if (format == @':ISO-8859-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1; + } + if (format == @':LATIN-1') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1; + } + if (format == @':US-ASCII') { + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; + } + if (ECL_HASH_TABLE_P(format)) { + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } + if (ECL_SYMBOLP(format)) { + format = si_make_encoding(format); + if (ECL_SYMBOLP(format)) + goto PARSE_SYMBOLS; + stream->stream.format_table = format; + return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT; + } #endif - FEerror("Unknown or unsupported external format: ~A", 1, format); - return ECL_STREAM_DEFAULT_FORMAT; + FEerror("Unknown or unsupported external format: ~A", 1, format); + return ECL_STREAM_DEFAULT_FORMAT; } static void set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags, - cl_object external_format) + cl_object external_format) { - cl_object t; - if (byte_size < 0) { - byte_size = -byte_size; - flags |= ECL_STREAM_SIGNED_BYTES; - t = @'signed-byte'; - } else { - flags &= ~ECL_STREAM_SIGNED_BYTES; - t = @'unsigned-byte'; - } - flags = parse_external_format(stream, external_format, flags); - stream->stream.ops->read_char = eformat_read_char; - stream->stream.ops->write_char = eformat_write_char; - switch (flags & ECL_STREAM_FORMAT) { - case ECL_STREAM_BINARY: - IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); - stream->stream.format = t; - stream->stream.ops->read_char = not_character_read_char; - stream->stream.ops->write_char = not_character_write_char; - break; + cl_object t; + if (byte_size < 0) { + byte_size = -byte_size; + flags |= ECL_STREAM_SIGNED_BYTES; + t = @'signed-byte'; + } else { + flags &= ~ECL_STREAM_SIGNED_BYTES; + t = @'unsigned-byte'; + } + flags = parse_external_format(stream, external_format, flags); + stream->stream.ops->read_char = eformat_read_char; + stream->stream.ops->write_char = eformat_write_char; + switch (flags & ECL_STREAM_FORMAT) { + case ECL_STREAM_BINARY: + IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size)); + stream->stream.format = t; + stream->stream.ops->read_char = not_character_read_char; + stream->stream.ops->write_char = not_character_write_char; + break; #ifdef ECL_UNICODE - /*case ECL_ISO_8859_1:*/ - case ECL_STREAM_LATIN_1: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':latin-1'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; - case ECL_STREAM_UTF_8: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = @':utf-8'; - stream->stream.encoder = utf_8_encoder; - stream->stream.decoder = utf_8_decoder; - break; - case ECL_STREAM_UCS_2: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - stream->stream.format = @':ucs-2'; - stream->stream.encoder = ucs_2_encoder; - stream->stream.decoder = ucs_2_decoder; - break; - case ECL_STREAM_UCS_2BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*2; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-2le'; - stream->stream.encoder = ucs_2le_encoder; - stream->stream.decoder = ucs_2le_decoder; - } else { - stream->stream.format = @':ucs-2be'; - stream->stream.encoder = ucs_2be_encoder; - stream->stream.decoder = ucs_2be_decoder; - } - break; - case ECL_STREAM_UCS_4: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4_encoder; - stream->stream.decoder = ucs_4_decoder; - break; - case ECL_STREAM_UCS_4BE: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8*4; - if (flags & ECL_STREAM_LITTLE_ENDIAN) { - stream->stream.format = @':ucs-4le'; - stream->stream.encoder = ucs_4le_encoder; - stream->stream.decoder = ucs_4le_decoder; - } else { - stream->stream.format = @':ucs-4be'; - stream->stream.encoder = ucs_4be_encoder; - stream->stream.decoder = ucs_4be_decoder; - } - break; - case ECL_STREAM_USER_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'character'; - byte_size = 8; - stream->stream.format = stream->stream.format_table; - if (CONSP(stream->stream.format)) { - stream->stream.encoder = user_multistate_encoder; - stream->stream.decoder = user_multistate_decoder; - } else { - stream->stream.encoder = user_encoder; - stream->stream.decoder = user_decoder; - } - break; - case ECL_STREAM_US_ASCII: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':us-ascii'; - stream->stream.encoder = ascii_encoder; - stream->stream.decoder = ascii_decoder; - break; + /*case ECL_ISO_8859_1:*/ + case ECL_STREAM_LATIN_1: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':latin-1'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; + case ECL_STREAM_UTF_8: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = @':utf-8'; + stream->stream.encoder = utf_8_encoder; + stream->stream.decoder = utf_8_decoder; + break; + case ECL_STREAM_UCS_2: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + stream->stream.format = @':ucs-2'; + stream->stream.encoder = ucs_2_encoder; + stream->stream.decoder = ucs_2_decoder; + break; + case ECL_STREAM_UCS_2BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*2; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-2le'; + stream->stream.encoder = ucs_2le_encoder; + stream->stream.decoder = ucs_2le_decoder; + } else { + stream->stream.format = @':ucs-2be'; + stream->stream.encoder = ucs_2be_encoder; + stream->stream.decoder = ucs_2be_decoder; + } + break; + case ECL_STREAM_UCS_4: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4_encoder; + stream->stream.decoder = ucs_4_decoder; + break; + case ECL_STREAM_UCS_4BE: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8*4; + if (flags & ECL_STREAM_LITTLE_ENDIAN) { + stream->stream.format = @':ucs-4le'; + stream->stream.encoder = ucs_4le_encoder; + stream->stream.decoder = ucs_4le_decoder; + } else { + stream->stream.format = @':ucs-4be'; + stream->stream.encoder = ucs_4be_encoder; + stream->stream.decoder = ucs_4be_decoder; + } + break; + case ECL_STREAM_USER_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = stream->stream.format_table; + if (CONSP(stream->stream.format)) { + stream->stream.encoder = user_multistate_encoder; + stream->stream.decoder = user_multistate_decoder; + } else { + stream->stream.encoder = user_encoder; + stream->stream.decoder = user_decoder; + } + break; + case ECL_STREAM_US_ASCII: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':us-ascii'; + stream->stream.encoder = ascii_encoder; + stream->stream.decoder = ascii_decoder; + break; #else - case ECL_STREAM_DEFAULT_FORMAT: - IO_STREAM_ELT_TYPE(stream) = @'base-char'; - byte_size = 8; - stream->stream.format = @':pass-through'; - stream->stream.encoder = passthrough_encoder; - stream->stream.decoder = passthrough_decoder; - break; + case ECL_STREAM_DEFAULT_FORMAT: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + byte_size = 8; + stream->stream.format = @':pass-through'; + stream->stream.encoder = passthrough_encoder; + stream->stream.decoder = passthrough_decoder; + break; #endif - default: - FEerror("Invalid or unsupported external format ~A with code ~D", - 2, external_format, ecl_make_fixnum(flags)); - } - t = @':LF'; - if (stream->stream.ops->write_char == eformat_write_char && - (flags & ECL_STREAM_CR)) { - if (flags & ECL_STREAM_LF) { - stream->stream.ops->read_char = eformat_read_char_crlf; - stream->stream.ops->write_char = eformat_write_char_crlf; - t = @':CRLF'; - } else { - stream->stream.ops->read_char = eformat_read_char_cr; - stream->stream.ops->write_char = eformat_write_char_cr; - t = @':CR'; - } - } - stream->stream.format = cl_list(2, stream->stream.format, t); - { - cl_object (*read_byte)(cl_object); - void (*write_byte)(cl_object,cl_object); - byte_size = (byte_size+7)&(~(cl_fixnum)7); - if (byte_size == 8) { - if (flags & ECL_STREAM_SIGNED_BYTES) { - read_byte = generic_read_byte_signed8; - write_byte = generic_write_byte_signed8; - } else { - read_byte = generic_read_byte_unsigned8; - write_byte = generic_write_byte_unsigned8; - } - } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { - read_byte = generic_read_byte_le; - write_byte = generic_write_byte_le; - } else { - read_byte = generic_read_byte; - write_byte = generic_write_byte; - } - if (ecl_input_stream_p(stream)) { - stream->stream.ops->read_byte = read_byte; - } - if (ecl_output_stream_p(stream)) { - stream->stream.ops->write_byte = write_byte; - } - } - stream->stream.flags = flags; - stream->stream.byte_size = byte_size; + default: + FEerror("Invalid or unsupported external format ~A with code ~D", + 2, external_format, ecl_make_fixnum(flags)); + } + t = @':LF'; + if (stream->stream.ops->write_char == eformat_write_char && + (flags & ECL_STREAM_CR)) { + if (flags & ECL_STREAM_LF) { + stream->stream.ops->read_char = eformat_read_char_crlf; + stream->stream.ops->write_char = eformat_write_char_crlf; + t = @':CRLF'; + } else { + stream->stream.ops->read_char = eformat_read_char_cr; + stream->stream.ops->write_char = eformat_write_char_cr; + t = @':CR'; + } + } + stream->stream.format = cl_list(2, stream->stream.format, t); + { + cl_object (*read_byte)(cl_object); + void (*write_byte)(cl_object,cl_object); + byte_size = (byte_size+7)&(~(cl_fixnum)7); + if (byte_size == 8) { + if (flags & ECL_STREAM_SIGNED_BYTES) { + read_byte = generic_read_byte_signed8; + write_byte = generic_write_byte_signed8; + } else { + read_byte = generic_read_byte_unsigned8; + write_byte = generic_write_byte_unsigned8; + } + } else if (flags & ECL_STREAM_LITTLE_ENDIAN) { + read_byte = generic_read_byte_le; + write_byte = generic_write_byte_le; + } else { + read_byte = generic_read_byte; + write_byte = generic_write_byte; + } + if (ecl_input_stream_p(stream)) { + stream->stream.ops->read_byte = read_byte; + } + if (ecl_output_stream_p(stream)) { + stream->stream.ops->write_byte = write_byte; + } + } + stream->stream.flags = flags; + stream->stream.byte_size = byte_size; } cl_object @@ -3261,7 +3261,7 @@ si_stream_external_format_set(cl_object stream, cl_object format) case ecl_smm_input_wsock: case ecl_smm_output_wsock: case ecl_smm_io_wsock: - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif { cl_object elt_type = ecl_stream_element_type(stream); @@ -3281,38 +3281,38 @@ si_stream_external_format_set(cl_object stream, cl_object format) cl_object ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, - cl_fixnum byte_size, int flags, cl_object external_format) + cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream = alloc_stream(); - switch(smm) { - case ecl_smm_input: - smm = ecl_smm_input_file; - case ecl_smm_input_file: - case ecl_smm_probe: - stream->stream.ops = duplicate_dispatch_table(&input_file_ops); - break; - case ecl_smm_output: - smm = ecl_smm_output_file; - case ecl_smm_output_file: - stream->stream.ops = duplicate_dispatch_table(&output_file_ops); - break; - case ecl_smm_io: - smm = ecl_smm_io_file; - case ecl_smm_io_file: - stream->stream.ops = duplicate_dispatch_table(&io_file_ops); - break; - default: - FEerror("make_stream: wrong mode", 0); - } - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_FILE_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; - IO_FILE_DESCRIPTOR(stream) = fd; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + cl_object stream = alloc_stream(); + switch(smm) { + case ecl_smm_input: + smm = ecl_smm_input_file; + case ecl_smm_input_file: + case ecl_smm_probe: + stream->stream.ops = duplicate_dispatch_table(&input_file_ops); + break; + case ecl_smm_output: + smm = ecl_smm_output_file; + case ecl_smm_output_file: + stream->stream.ops = duplicate_dispatch_table(&output_file_ops); + break; + case ecl_smm_io: + smm = ecl_smm_io_file; + case ecl_smm_io_file: + stream->stream.ops = duplicate_dispatch_table(&io_file_ops); + break; + default: + FEerror("make_stream: wrong mode", 0); + } + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_FILE_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; + IO_FILE_DESCRIPTOR(stream) = fd; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } /********************************************************************** @@ -3322,49 +3322,49 @@ ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, static cl_index input_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - FILE *f = IO_STREAM_FILE(strm); - cl_fixnum out = 0; - ecl_disable_interrupts(); - do { - out = fread(c, sizeof(char), n, f); - } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); - ecl_enable_interrupts(); - return out; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + FILE *f = IO_STREAM_FILE(strm); + cl_fixnum out = 0; + ecl_disable_interrupts(); + do { + out = fread(c, sizeof(char), n, f); + } while (out < n && ferror(f) && restartable_io_error(strm, "fread")); + ecl_enable_interrupts(); + return out; + } } static cl_index output_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out; - ecl_disable_interrupts(); - do { - out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); - } while (out < n && restartable_io_error(strm, "fwrite")); - ecl_enable_interrupts(); - return out; + cl_index out; + ecl_disable_interrupts(); + do { + out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); + } while (out < n && restartable_io_error(strm, "fwrite")); + ecl_enable_interrupts(); + return out; } static cl_index io_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * use some file position operation before reading again. Besides this, if - * there were unread octets, we have to move to the position at the - * begining of them. - */ - if (strm->stream.byte_stack != ECL_NIL) { - cl_object aux = ecl_file_position(strm); - if (!Null(aux)) - ecl_file_position_set(strm, aux); - } else if (strm->stream.last_op > 0) { - ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); - } - strm->stream.last_op = -1; - return output_stream_write_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * use some file position operation before reading again. Besides this, if + * there were unread octets, we have to move to the position at the + * begining of them. + */ + if (strm->stream.byte_stack != ECL_NIL) { + cl_object aux = ecl_file_position(strm); + if (!Null(aux)) + ecl_file_position_set(strm, aux); + } else if (strm->stream.last_op > 0) { + ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR); + } + strm->stream.last_op = -1; + return output_stream_write_byte8(strm, c, n); } static void io_stream_force_output(cl_object strm); @@ -3372,42 +3372,42 @@ static void io_stream_force_output(cl_object strm); static cl_index io_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - /* When using the same stream for input and output operations, we have to - * flush the stream before reading. - */ - if (strm->stream.last_op < 0) { - io_stream_force_output(strm); - } - strm->stream.last_op = +1; - return input_stream_read_byte8(strm, c, n); + /* When using the same stream for input and output operations, we have to + * flush the stream before reading. + */ + if (strm->stream.last_op < 0) { + io_stream_force_output(strm); + } + strm->stream.last_op = +1; + return input_stream_read_byte8(strm, c, n); } static int io_stream_listen(cl_object strm) { - if (strm->stream.byte_stack != ECL_NIL) - return ECL_LISTEN_AVAILABLE; - return flisten(strm, IO_STREAM_FILE(strm)); + if (strm->stream.byte_stack != ECL_NIL) + return ECL_LISTEN_AVAILABLE; + return flisten(strm, IO_STREAM_FILE(strm)); } static void io_stream_clear_input(cl_object strm) { - FILE *fp = IO_STREAM_FILE(strm); + FILE *fp = IO_STREAM_FILE(strm); #if defined(ECL_MS_WINDOWS_HOST) int f = fileno(fp); - if (isatty(f)) { - /* Flushes Win32 console */ - unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } + if (isatty(f)) { + /* Flushes Win32 console */ + unlikely_if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(f))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } #endif - while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { - ecl_disable_interrupts(); - getc(fp); - ecl_enable_interrupts(); - } + while (flisten(strm, fp) == ECL_LISTEN_AVAILABLE) { + ecl_disable_interrupts(); + getc(fp); + ecl_enable_interrupts(); + } } #define io_stream_clear_output generic_void @@ -3415,11 +3415,11 @@ io_stream_clear_input(cl_object strm) static void io_stream_force_output(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - ecl_disable_interrupts(); - while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) - (void)0; - ecl_enable_interrupts(); + FILE *f = IO_STREAM_FILE(strm); + ecl_disable_interrupts(); + while ((fflush(f) == EOF) && restartable_io_error(strm, "fflush")) + (void)0; + ecl_enable_interrupts(); } #define io_stream_finish_output io_stream_force_output @@ -3427,109 +3427,109 @@ io_stream_force_output(cl_object strm) static int io_stream_interactive_p(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - return isatty(fileno(f)); + FILE *f = IO_STREAM_FILE(strm); + return isatty(fileno(f)); } static cl_object io_stream_length(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output = ecl_file_len(fileno(f)); - if (strm->stream.byte_size != 8) { - const cl_env_ptr the_env = ecl_process_env(); - cl_index bs = strm->stream.byte_size; - output = ecl_floor2(output, ecl_make_fixnum(bs/8)); - unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - return output; + FILE *f = IO_STREAM_FILE(strm); + cl_object output = ecl_file_len(fileno(f)); + if (strm->stream.byte_size != 8) { + const cl_env_ptr the_env = ecl_process_env(); + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, ecl_make_fixnum(bs/8)); + unlikely_if (ecl_nth_value(the_env, 1) != ecl_make_fixnum(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; } static cl_object io_stream_get_position(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - cl_object output; - ecl_off_t offset; + FILE *f = IO_STREAM_FILE(strm); + cl_object output; + ecl_off_t offset; - ecl_disable_interrupts(); - offset = ecl_ftello(f); - ecl_enable_interrupts(); - if (offset < 0) - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - { - /* If there are unread octets, we return the position at which - * these bytes begin! */ - cl_object l = strm->stream.byte_stack; - while (CONSP(l)) { - output = ecl_one_minus(output); - l = ECL_CONS_CDR(l); - } - } - if (strm->stream.byte_size != 8) { - output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); - } - return output; + ecl_disable_interrupts(); + offset = ecl_ftello(f); + ecl_enable_interrupts(); + if (offset < 0) + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + { + /* If there are unread octets, we return the position at which + * these bytes begin! */ + cl_object l = strm->stream.byte_stack; + while (CONSP(l)) { + output = ecl_one_minus(output); + l = ECL_CONS_CDR(l); + } + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, ecl_make_fixnum(strm->stream.byte_size / 8)); + } + return output; } static cl_object io_stream_set_position(cl_object strm, cl_object large_disp) { - FILE *f = IO_STREAM_FILE(strm); - ecl_off_t disp; - int mode; - if (Null(large_disp)) { - disp = 0; - mode = SEEK_END; - } else { - if (strm->stream.byte_size != 8) { - large_disp = ecl_times(large_disp, - ecl_make_fixnum(strm->stream.byte_size / 8)); - } - disp = ecl_integer_to_off_t(large_disp); - mode = SEEK_SET; - } - ecl_disable_interrupts(); - mode = ecl_fseeko(f, disp, mode); - ecl_enable_interrupts(); - return mode? ECL_NIL : ECL_T; + FILE *f = IO_STREAM_FILE(strm); + ecl_off_t disp; + int mode; + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + ecl_make_fixnum(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + ecl_disable_interrupts(); + mode = ecl_fseeko(f, disp, mode); + ecl_enable_interrupts(); + return mode? ECL_NIL : ECL_T; } static int io_stream_column(cl_object strm) { - return strm->stream.column; + return strm->stream.column; } static cl_object io_stream_close(cl_object strm) { - FILE *f = IO_STREAM_FILE(strm); - int failed; - unlikely_if (f == stdout) - FEerror("Cannot close the standard output", 0); - unlikely_if (f == stdin) - FEerror("Cannot close the standard input", 0); - unlikely_if (f == NULL) - wrong_file_handler(strm); - if (ecl_output_stream_p(strm)) { - ecl_force_output(strm); - } - failed = safe_fclose(f); - unlikely_if (failed) - cannot_close(strm); + FILE *f = IO_STREAM_FILE(strm); + int failed; + unlikely_if (f == stdout) + FEerror("Cannot close the standard output", 0); + unlikely_if (f == stdin) + FEerror("Cannot close the standard input", 0); + unlikely_if (f == NULL) + wrong_file_handler(strm); + if (ecl_output_stream_p(strm)) { + ecl_force_output(strm); + } + failed = safe_fclose(f); + unlikely_if (failed) + cannot_close(strm); #if !defined(GBC_BOEHM) - ecl_dealloc(strm->stream.buffer); - IO_STREAM_FILE(strm) = NULL; + ecl_dealloc(strm->stream.buffer); + IO_STREAM_FILE(strm) = NULL; #endif - return generic_close(strm); + return generic_close(strm); } /* @@ -3540,102 +3540,102 @@ io_stream_close(cl_object strm) #define io_stream_write_vector io_file_write_vector const struct ecl_file_ops io_stream_ops = { - io_stream_write_byte8, - io_stream_read_byte8, + io_stream_write_byte8, + io_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - io_file_write_vector, + io_file_read_vector, + io_file_write_vector, - io_stream_listen, - io_stream_clear_input, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, + io_stream_listen, + io_stream_clear_input, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - io_stream_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + io_stream_interactive_p, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops output_stream_ops = { - output_stream_write_byte8, - not_input_read_byte8, + output_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - not_input_read_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + not_input_read_char, - generic_read_vector, - io_file_write_vector, + generic_read_vector, + io_file_write_vector, - not_input_listen, - generic_void, - io_stream_clear_output, - io_stream_finish_output, - io_stream_force_output, + not_input_listen, + generic_void, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - io_stream_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close }; const struct ecl_file_ops input_stream_ops = { - not_output_write_byte8, - input_stream_read_byte8, + not_output_write_byte8, + input_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - io_file_read_vector, - generic_write_vector, + io_file_read_vector, + generic_write_vector, - io_stream_listen, - io_stream_clear_input, - generic_void, - generic_void, - generic_void, + io_stream_listen, + io_stream_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - io_stream_interactive_p, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + io_stream_interactive_p, + io_file_element_type, - io_stream_length, - io_stream_get_position, - io_stream_set_position, - generic_column, - io_stream_close + io_stream_length, + io_stream_get_position, + io_stream_set_position, + generic_column, + io_stream_close }; /********************************************************************** @@ -3649,206 +3649,206 @@ const struct ecl_file_ops input_stream_ops = { static cl_index winsock_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index len = 0; + cl_index len = 0; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } - if(n > 0) { - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - len = recv(s, c, n, 0); - unlikely_if (len == SOCKET_ERROR) - wsock_error("Cannot read bytes from Windows " + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } + if(n > 0) { + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + len = recv(s, c, n, 0); + unlikely_if (len == SOCKET_ERROR) + wsock_error("Cannot read bytes from Windows " "socket ~S.~%~A", strm); - ecl_enable_interrupts(); - } - } - return (len > 0) ? len : EOF; + ecl_enable_interrupts(); + } + } + return (len > 0) ? len : EOF; } static cl_index winsock_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_index out = 0; - unsigned char *endp; - unsigned char *p; - SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } else { - ecl_disable_interrupts(); - do { - cl_index res = send(s, c + out, n, 0); - unlikely_if (res == SOCKET_ERROR) { - wsock_error("Cannot write bytes to Windows" + cl_index out = 0; + unsigned char *endp; + unsigned char *p; + SOCKET s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } else { + ecl_disable_interrupts(); + do { + cl_index res = send(s, c + out, n, 0); + unlikely_if (res == SOCKET_ERROR) { + wsock_error("Cannot write bytes to Windows" " socket ~S.~%~A", strm); - break; /* stop writing */ - } else { - out += res; - n -= res; - } - } while (n > 0); - ecl_enable_interrupts(); - } - return out; + break; /* stop writing */ + } else { + out += res; + n -= res; + } + } while (n > 0); + ecl_enable_interrupts(); + } + return out; } static int winsock_stream_listen(cl_object strm) { - SOCKET s; - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return ECL_LISTEN_AVAILABLE; - } - s = (SOCKET)IO_FILE_DESCRIPTOR(strm); - unlikely_if (INVALID_SOCKET == s) { - wrong_file_handler(strm); - } - { - struct timeval tv = { 0, 0 }; - fd_set fds; - cl_index result; - - FD_ZERO( &fds ); - FD_SET(s, &fds); - ecl_disable_interrupts(); - result = select( 0, &fds, NULL, NULL, &tv ); - unlikely_if (result == SOCKET_ERROR) - wsock_error("Cannot listen on Windows " - "socket ~S.~%~A", strm ); - ecl_enable_interrupts(); - return ( result > 0 - ? ECL_LISTEN_AVAILABLE - : ECL_LISTEN_NO_CHAR ); - } + SOCKET s; + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return ECL_LISTEN_AVAILABLE; + } + s = (SOCKET)IO_FILE_DESCRIPTOR(strm); + unlikely_if (INVALID_SOCKET == s) { + wrong_file_handler(strm); + } + { + struct timeval tv = { 0, 0 }; + fd_set fds; + cl_index result; + + FD_ZERO( &fds ); + FD_SET(s, &fds); + ecl_disable_interrupts(); + result = select( 0, &fds, NULL, NULL, &tv ); + unlikely_if (result == SOCKET_ERROR) + wsock_error("Cannot listen on Windows " + "socket ~S.~%~A", strm ); + ecl_enable_interrupts(); + return ( result > 0 + ? ECL_LISTEN_AVAILABLE + : ECL_LISTEN_NO_CHAR ); + } } static void winsock_stream_clear_input(cl_object strm) { - while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { - eformat_read_char(strm); - } + while (winsock_stream_listen(strm) == ECL_LISTEN_AVAILABLE) { + eformat_read_char(strm); + } } static cl_object winsock_stream_close(cl_object strm) { - SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); - int failed; - ecl_disable_interrupts(); - failed = closesocket(s); - ecl_enable_interrupts(); - unlikely_if (failed < 0) - cannot_close(strm); - IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; - return generic_close(strm); + SOCKET s = (SOCKET) IO_FILE_DESCRIPTOR(strm); + int failed; + ecl_disable_interrupts(); + failed = closesocket(s); + ecl_enable_interrupts(); + unlikely_if (failed < 0) + cannot_close(strm); + IO_FILE_DESCRIPTOR(strm) = (int)INVALID_SOCKET; + return generic_close(strm); } const struct ecl_file_ops winsock_stream_io_ops = { - winsock_stream_write_byte8, - winsock_stream_read_byte8, + winsock_stream_write_byte8, + winsock_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - winsock_stream_listen, - winsock_stream_clear_input, - generic_void, - generic_void, - generic_void, + winsock_stream_listen, + winsock_stream_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_output_ops = { - winsock_stream_write_byte8, - not_input_read_byte8, + winsock_stream_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, - generic_void, - generic_void, + not_input_listen, + not_input_clear_input, + generic_void, + generic_void, + generic_void, - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; const struct ecl_file_ops winsock_stream_input_ops = { - not_output_write_byte8, - winsock_stream_read_byte8, + not_output_write_byte8, + winsock_stream_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - winsock_stream_listen, - winsock_stream_clear_input, - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + winsock_stream_listen, + winsock_stream_clear_input, + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - winsock_stream_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + winsock_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - winsock_stream_close + winsock_stream_close }; #endif @@ -3863,165 +3863,165 @@ const struct ecl_file_ops winsock_stream_input_ops = { static cl_index wcon_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - unlikely_if (strm->stream.byte_stack != ECL_NIL) { - return consume_byte_stack(strm, c, n); - } else { - cl_index len = 0; - cl_env_ptr the_env = ecl_process_env(); - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unsigned char aux[4]; - for (len = 0; len < n; ) { - int i, ok; - ecl_disable_interrupts_env(the_env); - ok = ReadConsole(h, &aux, 1, &nchars, NULL); - ecl_enable_interrupts_env(the_env); - unlikely_if (!ok) { - FEwin32_error("Cannot read from console", 0); - } - for (i = 0; i < nchars; i++) { - if (len < n) { - c[len++] = aux[i]; - } else { - strm->stream.byte_stack = - ecl_nconc(strm->stream.byte_stack, - ecl_list1(ecl_make_fixnum(aux[i]))); - } - } - } - return (len > 0) ? len : EOF; - } + unlikely_if (strm->stream.byte_stack != ECL_NIL) { + return consume_byte_stack(strm, c, n); + } else { + cl_index len = 0; + cl_env_ptr the_env = ecl_process_env(); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unsigned char aux[4]; + for (len = 0; len < n; ) { + int i, ok; + ecl_disable_interrupts_env(the_env); + ok = ReadConsole(h, &aux, 1, &nchars, NULL); + ecl_enable_interrupts_env(the_env); + unlikely_if (!ok) { + FEwin32_error("Cannot read from console", 0); + } + for (i = 0; i < nchars; i++) { + if (len < n) { + c[len++] = aux[i]; + } else { + strm->stream.byte_stack = + ecl_nconc(strm->stream.byte_stack, + ecl_list1(ecl_make_fixnum(aux[i]))); + } + } + } + return (len > 0) ? len : EOF; + } } static cl_index wcon_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - DWORD nchars; - unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { - FEwin32_error("Cannot write to console.", 0); - } - return nchars; + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + DWORD nchars; + unlikely_if(!WriteConsole(h, c, n, &nchars, NULL)) { + FEwin32_error("Cannot write to console.", 0); + } + return nchars; } static int wcon_stream_listen(cl_object strm) { - HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); - INPUT_RECORD aux; - DWORD nevents; - do { - unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - if (nevents == 0) - return 0; - if (aux.EventType == KEY_EVENT) - return 1; - unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) - FEwin32_error("Cannot read from console.", 0); - } while (1); + HANDLE h = (HANDLE)IO_FILE_DESCRIPTOR(strm); + INPUT_RECORD aux; + DWORD nevents; + do { + unlikely_if(!PeekConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + if (nevents == 0) + return 0; + if (aux.EventType == KEY_EVENT) + return 1; + unlikely_if(!ReadConsoleInput(h, &aux, 1, &nevents)) + FEwin32_error("Cannot read from console.", 0); + } while (1); } static void wcon_stream_clear_input(cl_object strm) { - FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); + FlushConsoleInputBuffer((HANDLE)IO_FILE_DESCRIPTOR(strm)); } static void wcon_stream_force_output(cl_object strm) { - DWORD nchars; - WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); + DWORD nchars; + WriteConsole((HANDLE)IO_FILE_DESCRIPTOR(strm), 0, 0, &nchars, NULL); } const struct ecl_file_ops wcon_stream_io_ops = { - wcon_stream_write_byte8, - wcon_stream_read_byte8, + wcon_stream_write_byte8, + wcon_stream_read_byte8, - generic_write_byte, - generic_read_byte, + generic_write_byte, + generic_read_byte, - eformat_read_char, - eformat_write_char, - eformat_unread_char, - generic_peek_char, + eformat_read_char, + eformat_write_char, + eformat_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - wcon_stream_listen, - wcon_stream_clear_input, - generic_void, - wcon_stream_force_output, - wcon_stream_force_output, + wcon_stream_listen, + wcon_stream_clear_input, + generic_void, + wcon_stream_force_output, + wcon_stream_force_output, - generic_always_true, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - wcon_stream_element_type, + generic_always_true, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + wcon_stream_element_type, - not_a_file_stream, - not_implemented_get_position, - not_implemented_set_position, - generic_column, + not_a_file_stream, + not_implemented_get_position, + not_implemented_set_position, + generic_column, - generic_close, + generic_close, }; #define CONTROL_Z 26 static cl_object maybe_make_windows_console_FILE(cl_object fname, FILE *f, enum ecl_smmode smm, - cl_fixnum byte_size, int flags, - cl_object external_format) + cl_fixnum byte_size, int flags, + cl_object external_format) { - int desc = fileno(f); - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - output = ecl_make_stream_from_FILE - (fname, f, smm, byte_size, flags, - external_format); - } - return output; + int desc = fileno(f); + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + output = ecl_make_stream_from_FILE + (fname, f, smm, byte_size, flags, + external_format); + } + return output; } static cl_object maybe_make_windows_console_fd(cl_object fname, int desc, enum ecl_smmode smm, - cl_fixnum byte_size, int flags, - cl_object external_format) + cl_fixnum byte_size, int flags, + cl_object external_format) { - cl_object output; - if (isatty(desc)) { - output = ecl_make_stream_from_FILE - (fname, - (void*)_get_osfhandle(desc), - ecl_smm_io_wcon, - byte_size, flags, - external_format); - output->stream.eof_char = CONTROL_Z; - } else { - /* Windows changes the newline characters for \r\n - * even when using read()/write() */ - if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { - _setmode(desc, _O_BINARY); - } else { - external_format = ECL_CONS_CDR(external_format); - } - output = ecl_make_file_stream_from_fd - (fname, desc, smm, - byte_size, flags, - external_format); - } - return output; + cl_object output; + if (isatty(desc)) { + output = ecl_make_stream_from_FILE + (fname, + (void*)_get_osfhandle(desc), + ecl_smm_io_wcon, + byte_size, flags, + external_format); + output->stream.eof_char = CONTROL_Z; + } else { + /* Windows changes the newline characters for \r\n + * even when using read()/write() */ + if (ecl_option_values[ECL_OPT_USE_SETMODE_ON_FILES]) { + _setmode(desc, _O_BINARY); + } else { + external_format = ECL_CONS_CDR(external_format); + } + output = ecl_make_file_stream_from_fd + (fname, desc, smm, + byte_size, flags, + external_format); + } + return output; } #else #define maybe_make_windows_console_FILE ecl_make_stream_from_FILE @@ -4031,164 +4031,164 @@ maybe_make_windows_console_fd(cl_object fname, int desc, enum ecl_smmode smm, cl_object si_set_buffering_mode(cl_object stream, cl_object buffer_mode_symbol) { - enum ecl_smmode mode = stream->stream.mode; - int buffer_mode; + enum ecl_smmode mode = stream->stream.mode; + int buffer_mode; - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { - FEerror("Cannot set buffer of ~A", 1, stream); - } + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + FEerror("Cannot set buffer of ~A", 1, stream); + } - if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) - buffer_mode = _IONBF; - else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') - buffer_mode = _IOLBF; - else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') - buffer_mode = _IOFBF; - else - FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); + if (buffer_mode_symbol == @':none' || Null(buffer_mode_symbol)) + buffer_mode = _IONBF; + else if (buffer_mode_symbol == @':line' || buffer_mode_symbol == @':line-buffered') + buffer_mode = _IOLBF; + else if (buffer_mode_symbol == @':full' || buffer_mode_symbol == @':fully-buffered') + buffer_mode = _IOFBF; + else + FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); - if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { - FILE *fp = IO_STREAM_FILE(stream); + if (mode == ecl_smm_output || mode == ecl_smm_io || mode == ecl_smm_input) { + FILE *fp = IO_STREAM_FILE(stream); - if (buffer_mode != _IONBF) { - cl_index buffer_size = BUFSIZ; - char *new_buffer = ecl_alloc_atomic(buffer_size); - stream->stream.buffer = new_buffer; - setvbuf(fp, new_buffer, buffer_mode, buffer_size); - } else - setvbuf(fp, NULL, _IONBF, 0); - } - @(return stream) + if (buffer_mode != _IONBF) { + cl_index buffer_size = BUFSIZ; + char *new_buffer = ecl_alloc_atomic(buffer_size); + stream->stream.buffer = new_buffer; + setvbuf(fp, new_buffer, buffer_mode, buffer_size); + } else + setvbuf(fp, NULL, _IONBF, 0); + } + @(return stream) } cl_object ecl_make_stream_from_FILE(cl_object fname, void *f, enum ecl_smmode smm, - cl_fixnum byte_size, int flags, cl_object external_format) + cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object stream; - stream = alloc_stream(); - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - switch (smm) { - case ecl_smm_io: - stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); - break; - case ecl_smm_probe: - case ecl_smm_input: - stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); - break; - case ecl_smm_output: - stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); - break; + cl_object stream; + stream = alloc_stream(); + stream->stream.mode = (short)smm; + stream->stream.closed = 0; + switch (smm) { + case ecl_smm_io: + stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); + break; + case ecl_smm_probe: + case ecl_smm_input: + stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); + break; + case ecl_smm_output: + stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); - break; - case ecl_smm_output_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); - break; - case ecl_smm_io_wsock: - stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); - break; - case ecl_smm_io_wcon: - stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); - break; + case ecl_smm_input_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_input_ops); + break; + case ecl_smm_output_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_output_ops); + break; + case ecl_smm_io_wsock: + stream->stream.ops = duplicate_dispatch_table(&winsock_stream_io_ops); + break; + case ecl_smm_io_wcon: + stream->stream.ops = duplicate_dispatch_table(&wcon_stream_io_ops); + break; #endif - default: - FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); - } - set_stream_elt_type(stream, byte_size, flags, external_format); - IO_STREAM_FILENAME(stream) = fname; /* not really used */ - stream->stream.column = 0; + default: + FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, ecl_make_fixnum(smm)); + } + set_stream_elt_type(stream, byte_size, flags, external_format); + IO_STREAM_FILENAME(stream) = fname; /* not really used */ + stream->stream.column = 0; IO_STREAM_FILE(stream) = f; - stream->stream.last_op = 0; - si_set_finalizer(stream, ECL_T); - return stream; + stream->stream.last_op = 0; + si_set_finalizer(stream, ECL_T); + return stream; } cl_object ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, - cl_fixnum byte_size, int flags, cl_object external_format) + cl_fixnum byte_size, int flags, cl_object external_format) { - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - switch(smm) { - case ecl_smm_input: - mode = OPEN_R; - break; - case ecl_smm_output: - mode = OPEN_W; - break; - case ecl_smm_io: - mode = OPEN_RW; - break; + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + switch(smm) { + case ecl_smm_input: + mode = OPEN_R; + break; + case ecl_smm_output: + mode = OPEN_W; + break; + case ecl_smm_io: + mode = OPEN_RW; + break; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: - case ecl_smm_io_wcon: - break; + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: + case ecl_smm_io_wcon: + break; #endif - default: - FEerror("make_stream: wrong mode", 0); - } + default: + FEerror("make_stream: wrong mode", 0); + } #if defined(ECL_WSOCK) - if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) - fp = (FILE*)fd; - else - fp = safe_fdopen(fd, mode); + if (smm == ecl_smm_input_wsock || smm == ecl_smm_output_wsock || smm == ecl_smm_io_wsock || smm == ecl_smm_io_wcon) + fp = (FILE*)fd; + else + fp = safe_fdopen(fd, mode); #else - fp = safe_fdopen(fd, mode); + fp = safe_fdopen(fd, mode); #endif if (fp == NULL) { FElibc_error("Unable to create stream for file descriptor ~D", 1, ecl_make_integer(fd)); } - return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, - external_format); + return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags, + external_format); } int ecl_stream_to_handle(cl_object s, bool output) { BEGIN: - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return -1; - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - if (output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_input_file: - if (output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_output: - if (!output) return -1; - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_output_file: - if (!output) return -1; - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_io: - return fileno(IO_STREAM_FILE(s)); - case ecl_smm_io_file: - return IO_FILE_DESCRIPTOR(s); - case ecl_smm_synonym: - s = SYNONYM_STREAM_STREAM(s); - goto BEGIN; - case ecl_smm_two_way: - s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); - goto BEGIN; + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return -1; + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + if (output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_input_file: + if (output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_output: + if (!output) return -1; + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_output_file: + if (!output) return -1; + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_io: + return fileno(IO_STREAM_FILE(s)); + case ecl_smm_io_file: + return IO_FILE_DESCRIPTOR(s); + case ecl_smm_synonym: + s = SYNONYM_STREAM_STREAM(s); + goto BEGIN; + case ecl_smm_two_way: + s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); + goto BEGIN; #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - return -1; - default: - ecl_internal_error("illegal stream mode"); - } + return -1; + default: + ecl_internal_error("illegal stream mode"); + } } cl_object @@ -4196,23 +4196,23 @@ si_file_stream_fd(cl_object s) { cl_object ret; - unlikely_if (!ECL_ANSI_STREAM_P(s)) - FEerror("file_stream_fd: not a stream", 0); + unlikely_if (!ECL_ANSI_STREAM_P(s)) + FEerror("file_stream_fd: not a stream", 0); - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); break; - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); break; - default: - ecl_internal_error("not a file stream"); - } + default: + ecl_internal_error("not a file stream"); + } @(return ret); } @@ -4223,104 +4223,104 @@ si_file_stream_fd(cl_object s) static cl_index seq_in_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); - cl_fixnum last = SEQ_INPUT_LIMIT(strm); - cl_fixnum delta = last - curr_pos; - if (delta > 0) { - cl_object vector = SEQ_INPUT_VECTOR(strm); - if (delta > n) delta = n; - memcpy(c, vector->vector.self.bc + curr_pos, delta); - SEQ_INPUT_POSITION(strm) += delta; - return delta; - } - return 0; + cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm); + cl_fixnum last = SEQ_INPUT_LIMIT(strm); + cl_fixnum delta = last - curr_pos; + if (delta > 0) { + cl_object vector = SEQ_INPUT_VECTOR(strm); + if (delta > n) delta = n; + memcpy(c, vector->vector.self.bc + curr_pos, delta); + SEQ_INPUT_POSITION(strm) += delta; + return delta; + } + return 0; } static void seq_in_unread_char(cl_object strm, ecl_character c) { - eformat_unread_char(strm, c); - SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); - strm->stream.byte_stack = ECL_NIL; + eformat_unread_char(strm, c); + SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack); + strm->stream.byte_stack = ECL_NIL; } static int seq_in_listen(cl_object strm) { - if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; + if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; } static cl_object seq_in_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm)); } static cl_object seq_in_set_position(cl_object strm, cl_object pos) { - cl_fixnum disp; - if (Null(pos)) { - disp = SEQ_INPUT_LIMIT(strm); - } else { - disp = ecl_to_size(pos); - if (disp >= SEQ_INPUT_LIMIT(strm)) { - disp = SEQ_INPUT_LIMIT(strm); - } - } - SEQ_INPUT_POSITION(strm) = disp; - return ECL_T; + cl_fixnum disp; + if (Null(pos)) { + disp = SEQ_INPUT_LIMIT(strm); + } else { + disp = ecl_to_size(pos); + if (disp >= SEQ_INPUT_LIMIT(strm)) { + disp = SEQ_INPUT_LIMIT(strm); + } + } + SEQ_INPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_in_ops = { - not_output_write_byte8, - seq_in_read_byte8, + not_output_write_byte8, + seq_in_read_byte8, - not_output_write_byte, - generic_read_byte, + not_output_write_byte, + generic_read_byte, - eformat_read_char, - not_output_write_char, - seq_in_unread_char, - generic_peek_char, + eformat_read_char, + not_output_write_char, + seq_in_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - seq_in_listen, - generic_void, /* clear-input */ - not_output_clear_output, - not_output_finish_output, - not_output_force_output, + seq_in_listen, + generic_void, /* clear-input */ + not_output_clear_output, + not_output_finish_output, + not_output_force_output, - generic_always_true, /* input_p */ - generic_always_false, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_true, /* input_p */ + generic_always_false, /* output_p */ + generic_always_false, + io_file_element_type, - not_a_file_stream, /* length */ - seq_in_get_position, - seq_in_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + seq_in_get_position, + seq_in_set_position, + generic_column, + generic_close }; static cl_object make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, cl_object external_format) { - cl_object strm; + cl_object strm; cl_elttype type; cl_object type_name; int byte_size; int flags = 0; if (!ECL_VECTORP(vector) || ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) { FEerror("MAKE-SEQUENCE-INPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); } @@ -4329,8 +4329,8 @@ make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, /* Character streams always get some external format. For binary * sequences it has to be explicitly mentioned. */ strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); - strm->stream.mode = (short)ecl_smm_sequence_input; + strm->stream.ops = duplicate_dispatch_table(&seq_in_ops); + strm->stream.mode = (short)ecl_smm_sequence_input; if (!byte_size) { #if defined(ECL_UNICODE) if (ECL_BASE_STRING_P(vector)) { @@ -4354,10 +4354,10 @@ make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, set_stream_elt_type(strm, byte_size, flags, external_format); /* Override byte size and elt type */ if (byte_size) strm->stream.byte_size = byte_size; - SEQ_INPUT_VECTOR(strm) = vector; - SEQ_INPUT_POSITION(strm) = istart; - SEQ_INPUT_LIMIT(strm) = iend; - return strm; + SEQ_INPUT_VECTOR(strm) = vector; + SEQ_INPUT_POSITION(strm) = istart; + SEQ_INPUT_LIMIT(strm) = iend; + return strm; } @(defun ext::make_sequence_input_stream (vector &key @@ -4368,7 +4368,7 @@ make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend, @ p = ecl_vector_start_end(@[ext::make-sequence-input-stream], vector, start, end); - @(return make_sequence_input_stream(vector, p.start, p.end, + @(return make_sequence_input_stream(vector, p.start, p.end, external_format)) @) @@ -4381,21 +4381,21 @@ seq_out_write_byte8(cl_object strm, unsigned char *c, cl_index n) { AGAIN: { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_object vector = SEQ_OUTPUT_VECTOR(strm); cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm); - cl_fixnum last = vector->vector.dim; + cl_fixnum last = vector->vector.dim; cl_fixnum delta = last - curr_pos; if (delta < n) { /* Not enough space, enlarge */ vector = _ecl_funcall3(@'adjust-array', vector, - ecl_ash(ecl_make_fixnum(last), 1)); + ecl_ash(ecl_make_fixnum(last), 1)); SEQ_OUTPUT_VECTOR(strm) = vector; goto AGAIN; } memcpy(vector->vector.self.bc + curr_pos, c, n); SEQ_OUTPUT_POSITION(strm) = curr_pos += n; - if (vector->vector.fillp < curr_pos) - vector->vector.fillp = curr_pos; + if (vector->vector.fillp < curr_pos) + vector->vector.fillp = curr_pos; } return n; } @@ -4403,71 +4403,71 @@ seq_out_write_byte8(cl_object strm, unsigned char *c, cl_index n) static cl_object seq_out_get_position(cl_object strm) { - return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); + return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm)); } static cl_object seq_out_set_position(cl_object strm, cl_object pos) { - cl_object vector = SEQ_OUTPUT_VECTOR(strm); - cl_fixnum disp; - if (Null(pos)) { - disp = vector->vector.fillp; - } else { - disp = ecl_to_size(pos); - if (disp >= vector->vector.dim) { - disp = vector->vector.fillp; - } - } - SEQ_OUTPUT_POSITION(strm) = disp; - return ECL_T; + cl_object vector = SEQ_OUTPUT_VECTOR(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = vector->vector.fillp; + } else { + disp = ecl_to_size(pos); + if (disp >= vector->vector.dim) { + disp = vector->vector.fillp; + } + } + SEQ_OUTPUT_POSITION(strm) = disp; + return ECL_T; } const struct ecl_file_ops seq_out_ops = { - seq_out_write_byte8, - not_input_read_byte8, + seq_out_write_byte8, + not_input_read_byte8, - generic_write_byte, - not_input_read_byte, + generic_write_byte, + not_input_read_byte, - not_input_read_char, - eformat_write_char, - not_input_unread_char, - generic_peek_char, + not_input_read_char, + eformat_write_char, + not_input_unread_char, + generic_peek_char, - generic_read_vector, - generic_write_vector, + generic_read_vector, + generic_write_vector, - not_input_listen, - not_input_clear_input, - generic_void, /* clear-output */ - generic_void, /* finish-output */ - generic_void, /* force-output */ + not_input_listen, + not_input_clear_input, + generic_void, /* clear-output */ + generic_void, /* finish-output */ + generic_void, /* force-output */ - generic_always_false, /* input_p */ - generic_always_true, /* output_p */ - generic_always_false, - io_file_element_type, + generic_always_false, /* input_p */ + generic_always_true, /* output_p */ + generic_always_false, + io_file_element_type, - not_a_file_stream, /* length */ - seq_out_get_position, - seq_out_set_position, - generic_column, - generic_close + not_a_file_stream, /* length */ + seq_out_get_position, + seq_out_set_position, + generic_column, + generic_close }; static cl_object make_sequence_output_stream(cl_object vector, cl_object external_format) { - cl_object strm; + cl_object strm; cl_elttype type; cl_object type_name; int byte_size; int flags = 0; if (!ECL_VECTORP(vector) || ((type = ecl_array_elttype(vector)) < ecl_aet_b8 && - type > ecl_aet_bc) || - ecl_aet_size[type] != 1) + type > ecl_aet_bc) || + ecl_aet_size[type] != 1) { FEerror("MAKE-SEQUENCE-OUTPUT-STREAM only accepts vectors whose element has a size of 1 byte.~%~A", 1, vector); } @@ -4475,9 +4475,9 @@ make_sequence_output_stream(cl_object vector, cl_object external_format) byte_size = ecl_normalize_stream_element_type(type_name); /* Character streams always get some external format. For binary * sequences it has to be explicitly mentioned. */ - strm = alloc_stream(); - strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); - strm->stream.mode = (short)ecl_smm_sequence_output; + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&seq_out_ops); + strm->stream.mode = (short)ecl_smm_sequence_output; if (!byte_size) { #if defined(ECL_UNICODE) if (ECL_BASE_STRING_P(vector)) { @@ -4501,14 +4501,14 @@ make_sequence_output_stream(cl_object vector, cl_object external_format) set_stream_elt_type(strm, byte_size, flags, external_format); /* Override byte size and elt type */ if (byte_size) strm->stream.byte_size = byte_size; - SEQ_OUTPUT_VECTOR(strm) = vector; - SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; - return strm; + SEQ_OUTPUT_VECTOR(strm) = vector; + SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp; + return strm; } @(defun ext::make_sequence_output_stream (vector &key (external_format ECL_NIL)) @ - @(return make_sequence_output_stream(vector, external_format)) + @(return make_sequence_output_stream(vector, external_format)) @) /********************************************************************** @@ -4518,151 +4518,151 @@ make_sequence_output_stream(cl_object vector, cl_object external_format) struct ecl_file_ops * duplicate_dispatch_table(const struct ecl_file_ops *ops) { - struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); - *new_ops = *ops; - return new_ops; + struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); + *new_ops = *ops; + return new_ops; } const struct ecl_file_ops * stream_dispatch_table(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return &clos_stream_ops; - } + if (ECL_INSTANCEP(strm)) { + return &clos_stream_ops; + } #endif - if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_argument(@[stream], strm); - return (const struct ecl_file_ops *)strm->stream.ops; + if (!ECL_ANSI_STREAM_P(strm)) + FEwrong_type_argument(@[stream], strm); + return (const struct ecl_file_ops *)strm->stream.ops; } static cl_index ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->read_byte8(strm, c, n); + return stream_dispatch_table(strm)->read_byte8(strm, c, n); } static cl_index ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - return stream_dispatch_table(strm)->write_byte8(strm, c, n); + return stream_dispatch_table(strm)->write_byte8(strm, c, n); } ecl_character ecl_read_char(cl_object strm) { - return stream_dispatch_table(strm)->read_char(strm); + return stream_dispatch_table(strm)->read_char(strm); } ecl_character ecl_read_char_noeof(cl_object strm) { - ecl_character c = ecl_read_char(strm); - if (c == EOF) - FEend_of_file(strm); - return c; + ecl_character c = ecl_read_char(strm); + if (c == EOF) + FEend_of_file(strm); + return c; } cl_object ecl_read_byte(cl_object strm) { - return stream_dispatch_table(strm)->read_byte(strm); + return stream_dispatch_table(strm)->read_byte(strm); } void ecl_write_byte(cl_object c, cl_object strm) { - stream_dispatch_table(strm)->write_byte(c, strm); + stream_dispatch_table(strm)->write_byte(c, strm); } ecl_character ecl_write_char(ecl_character c, cl_object strm) { - return stream_dispatch_table(strm)->write_char(strm, c); + return stream_dispatch_table(strm)->write_char(strm, c); } void ecl_unread_char(ecl_character c, cl_object strm) { - stream_dispatch_table(strm)->unread_char(strm, c); + stream_dispatch_table(strm)->unread_char(strm, c); } int ecl_listen_stream(cl_object strm) { - return stream_dispatch_table(strm)->listen(strm); + return stream_dispatch_table(strm)->listen(strm); } void ecl_clear_input(cl_object strm) { - stream_dispatch_table(strm)->clear_input(strm); + stream_dispatch_table(strm)->clear_input(strm); } void ecl_clear_output(cl_object strm) { - stream_dispatch_table(strm)->clear_output(strm); + stream_dispatch_table(strm)->clear_output(strm); } void ecl_force_output(cl_object strm) { - stream_dispatch_table(strm)->force_output(strm); + stream_dispatch_table(strm)->force_output(strm); } void ecl_finish_output(cl_object strm) { - stream_dispatch_table(strm)->finish_output(strm); + stream_dispatch_table(strm)->finish_output(strm); } int ecl_file_column(cl_object strm) { - return stream_dispatch_table(strm)->column(strm); + return stream_dispatch_table(strm)->column(strm); } cl_object ecl_file_length(cl_object strm) { - return stream_dispatch_table(strm)->length(strm); + return stream_dispatch_table(strm)->length(strm); } cl_object ecl_file_position(cl_object strm) { - return stream_dispatch_table(strm)->get_position(strm); + return stream_dispatch_table(strm)->get_position(strm); } cl_object ecl_file_position_set(cl_object strm, cl_object pos) { - return stream_dispatch_table(strm)->set_position(strm, pos); + return stream_dispatch_table(strm)->set_position(strm, pos); } bool ecl_input_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->input_p(strm); + return stream_dispatch_table(strm)->input_p(strm); } bool ecl_output_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->output_p(strm); + return stream_dispatch_table(strm)->output_p(strm); } cl_object ecl_stream_element_type(cl_object strm) { - return stream_dispatch_table(strm)->element_type(strm); + return stream_dispatch_table(strm)->element_type(strm); } int ecl_interactive_stream_p(cl_object strm) { - return stream_dispatch_table(strm)->interactive_p(strm); + return stream_dispatch_table(strm)->interactive_p(strm); } /* @@ -4677,7 +4677,7 @@ ecl_interactive_stream_p(cl_object strm) ecl_character ecl_peek_char(cl_object strm) { - return stream_dispatch_table(strm)->peek_char(strm); + return stream_dispatch_table(strm)->peek_char(strm); } /*******************************tl*************************************** @@ -4687,89 +4687,89 @@ ecl_peek_char(cl_object strm) void writestr_stream(const char *s, cl_object strm) { - while (*s != '\0') - ecl_write_char(*s++, strm); + while (*s != '\0') + ecl_write_char(*s++, strm); } static cl_index compute_char_size(cl_object stream, ecl_character c) { - unsigned char buffer[5]; - int l = 0; - if (c == ECL_CHAR_CODE_NEWLINE) { - int flags = stream->stream.flags; - if (flags & ECL_STREAM_CR) { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); - if (flags & ECL_STREAM_LF) - l += stream->stream.encoder(stream, buffer, - ECL_CHAR_CODE_LINEFEED); - } else { - l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); - } - } else { - l += stream->stream.encoder(stream, buffer, c); - } - return l; + unsigned char buffer[5]; + int l = 0; + if (c == ECL_CHAR_CODE_NEWLINE) { + int flags = stream->stream.flags; + if (flags & ECL_STREAM_CR) { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN); + if (flags & ECL_STREAM_LF) + l += stream->stream.encoder(stream, buffer, + ECL_CHAR_CODE_LINEFEED); + } else { + l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED); + } + } else { + l += stream->stream.encoder(stream, buffer, c); + } + return l; } cl_object cl_file_string_length(cl_object stream, cl_object string) { - cl_fixnum l = 0; - /* This is a stupid requirement from the spec. Why returning 1??? - * Why not simply leaving the value unspecified, as with other - * streams one cannot write to??? - */ + cl_fixnum l = 0; + /* This is a stupid requirement from the spec. Why returning 1??? + * Why not simply leaving the value unspecified, as with other + * streams one cannot write to??? + */ BEGIN: #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(stream)) { - @(return ECL_NIL) - } + if (ECL_INSTANCEP(stream)) { + @(return ECL_NIL) + } #endif - unlikely_if (!ECL_ANSI_STREAM_P(stream)) { + unlikely_if (!ECL_ANSI_STREAM_P(stream)) { FEwrong_type_only_arg(@[file-string-length], stream, @[stream]); - } - if (stream->stream.mode == ecl_smm_broadcast) { - stream = BROADCAST_STREAM_LIST(stream); - if (Null(stream)) { - @(return ecl_make_fixnum(1)); - } else { - goto BEGIN; - } - } - unlikely_if (!ECL_FILE_STREAM_P(stream)) { - not_a_file_stream(stream); - } - switch (ecl_t_of(string)) { + } + if (stream->stream.mode == ecl_smm_broadcast) { + stream = BROADCAST_STREAM_LIST(stream); + if (Null(stream)) { + @(return ecl_make_fixnum(1)); + } else { + goto BEGIN; + } + } + unlikely_if (!ECL_FILE_STREAM_P(stream)) { + not_a_file_stream(stream); + } + switch (ecl_t_of(string)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: { - cl_index i; - for (i = 0; i < string->base_string.fillp; i++) { - l += compute_char_size(stream, ecl_char(string, i)); - } - break; - } - case t_character: - l = compute_char_size(stream, ECL_CHAR_CODE(string)); - break; - default: + case t_base_string: { + cl_index i; + for (i = 0; i < string->base_string.fillp; i++) { + l += compute_char_size(stream, ecl_char(string, i)); + } + break; + } + case t_character: + l = compute_char_size(stream, ECL_CHAR_CODE(string)); + break; + default: FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]); - } - @(return ecl_make_fixnum(l)) + } + @(return ecl_make_fixnum(l)) } cl_object si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); if (ecl_unlikely(!ECL_FIXNUMP(s) || ((start = ecl_fixnum(s)) < 0) || (start > limit))) { @@ -4777,52 +4777,52 @@ si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) ecl_make_integer_type(ecl_make_fixnum(0), ecl_make_fixnum(limit-1))); } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || ((end = ecl_fixnum(e)) < 0) || (end > limit))) { FEwrong_type_key_arg(@[write-sequence], @[:end], e, ecl_make_integer_type(ecl_make_fixnum(0), ecl_make_fixnum(limit))); } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - cl_object s = ecl_nthcdr(start, seq); - loop_for_in(s) { - if (start < end) { - cl_object elt = CAR(s); - if (ischar) - ops->write_char(stream, ecl_char_code(elt)); - else - ops->write_byte(elt, stream); - start++; - } else { - goto OUTPUT; - } - } end_loop_for_in; - } else { - ops->write_vector(stream, seq, start, end); - } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + cl_object s = ecl_nthcdr(start, seq); + loop_for_in(s) { + if (start < end) { + cl_object elt = CAR(s); + if (ischar) + ops->write_char(stream, ecl_char_code(elt)); + else + ops->write_byte(elt, stream); + start++; + } else { + goto OUTPUT; + } + } end_loop_for_in; + } else { + ops->write_vector(stream, seq, start, end); + } OUTPUT: - @(return seq); + @(return seq); } cl_object si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) { - const struct ecl_file_ops *ops; - cl_fixnum start,limit,end; + const struct ecl_file_ops *ops; + cl_fixnum start,limit,end; - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == ECL_NIL i.f.f. t = t_symbol */ - limit = ecl_length(seq); + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == ECL_NIL i.f.f. t = t_symbol */ + limit = ecl_length(seq); if (ecl_unlikely(!ECL_FIXNUMP(s) || ((start = ecl_fixnum(s)) < 0) || (start > limit))) { @@ -4830,45 +4830,45 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) ecl_make_integer_type(ecl_make_fixnum(0), ecl_make_fixnum(limit-1))); } - if (e == ECL_NIL) { - end = limit; - } else if (ecl_unlikely(!ECL_FIXNUMP(e) || + if (e == ECL_NIL) { + end = limit; + } else if (ecl_unlikely(!ECL_FIXNUMP(e) || ((end = ecl_fixnum(e)) < 0) || (end > limit))) { FEwrong_type_key_arg(@[read-sequence], @[:end], e, ecl_make_integer_type(ecl_make_fixnum(0), ecl_make_fixnum(limit))); } - if (end <= start) { - goto OUTPUT; - } - ops = stream_dispatch_table(stream); - if (LISTP(seq)) { - cl_object elt_type = cl_stream_element_type(stream); - bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); - seq = ecl_nthcdr(start, seq); - loop_for_in(seq) { - if (start >= end) { - goto OUTPUT; - } else { - cl_object c; - if (ischar) { - int i = ops->read_char(stream); - if (i < 0) goto OUTPUT; - c = ECL_CODE_CHAR(i); - } else { - c = ops->read_byte(stream); - if (c == ECL_NIL) goto OUTPUT; - } - ECL_RPLACA(seq, c); - start++; - } - } end_loop_for_in; - } else { - start = ops->read_vector(stream, seq, start, end); - } + if (end <= start) { + goto OUTPUT; + } + ops = stream_dispatch_table(stream); + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + seq = ecl_nthcdr(start, seq); + loop_for_in(seq) { + if (start >= end) { + goto OUTPUT; + } else { + cl_object c; + if (ischar) { + int i = ops->read_char(stream); + if (i < 0) goto OUTPUT; + c = ECL_CODE_CHAR(i); + } else { + c = ops->read_byte(stream); + if (c == ECL_NIL) goto OUTPUT; + } + ECL_RPLACA(seq, c); + start++; + } + } end_loop_for_in; + } else { + start = ops->read_vector(stream, seq, start, end); + } OUTPUT: - @(return ecl_make_fixnum(start)) + @(return ecl_make_fixnum(start)) } /********************************************************************** @@ -4878,102 +4878,102 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) cl_object si_file_column(cl_object strm) { - @(return ecl_make_fixnum(ecl_file_column(strm))) + @(return ecl_make_fixnum(ecl_file_column(strm))) } cl_object cl_file_length(cl_object strm) { - @(return ecl_file_length(strm)) + @(return ecl_file_length(strm)) } @(defun file-position (file_stream &o position) - cl_object output; + cl_object output; @ - if (Null(position)) { - output = ecl_file_position(file_stream); - } else { - if (position == @':start') { - position = ecl_make_fixnum(0); - } else if (position == @':end') { - position = ECL_NIL; - } - output = ecl_file_position_set(file_stream, position); - } - @(return output) + if (Null(position)) { + output = ecl_file_position(file_stream); + } else { + if (position == @':start') { + position = ecl_make_fixnum(0); + } else if (position == @':end') { + position = ECL_NIL; + } + output = ecl_file_position_set(file_stream, position); + } + @(return output) @) cl_object cl_input_stream_p(cl_object strm) { - @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_input_stream_p(strm) ? ECL_T : ECL_NIL)) } cl_object cl_output_stream_p(cl_object strm) { - @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)) + @(return (ecl_output_stream_p(strm) ? ECL_T : ECL_NIL)) } cl_object cl_interactive_stream_p(cl_object strm) { - @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)) + @(return (stream_dispatch_table(strm)->interactive_p(strm)? ECL_T : ECL_NIL)) } cl_object cl_open_stream_p(cl_object strm) { - /* ANSI and Cltl2 specify that open-stream-p should work - on closed streams, and that a stream is only closed - when #'close has been applied on it */ + /* ANSI and Cltl2 specify that open-stream-p should work + on closed streams, and that a stream is only closed + when #'close has been applied on it */ #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::open-stream-p', strm); - } + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::open-stream-p', strm); + } #endif - unlikely_if (!ECL_ANSI_STREAM_P(strm)) + unlikely_if (!ECL_ANSI_STREAM_P(strm)) FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); - @(return (strm->stream.closed ? ECL_NIL : ECL_T)) + @(return (strm->stream.closed ? ECL_NIL : ECL_T)) } cl_object cl_stream_element_type(cl_object strm) { - @(return ecl_stream_element_type(strm)) + @(return ecl_stream_element_type(strm)) } cl_object cl_stream_external_format(cl_object strm) { - cl_object output; - cl_type t; + cl_object output; + cl_type t; AGAIN: - t= ecl_t_of(strm); + t= ecl_t_of(strm); #ifdef ECL_CLOS_STREAMS - if (t == t_instance) - output = @':default'; - else + if (t == t_instance) + output = @':default'; + else #endif unlikely_if (t != t_stream) FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); - if (strm->stream.mode == ecl_smm_synonym) { - strm = SYNONYM_STREAM_STREAM(strm); - goto AGAIN; - } - output = strm->stream.format; - @(return output) + if (strm->stream.mode == ecl_smm_synonym) { + strm = SYNONYM_STREAM_STREAM(strm); + goto AGAIN; + } + output = strm->stream.format; + @(return output) } cl_object cl_streamp(cl_object strm) { #ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return _ecl_funcall2(@'gray::streamp', strm); - } + if (ECL_INSTANCEP(strm)) { + return _ecl_funcall2(@'gray::streamp', strm); + } #endif - @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)) + @(return (ECL_ANSI_STREAM_P(strm) ? ECL_T : ECL_NIL)) } /********************************************************************** @@ -4983,12 +4983,12 @@ cl_streamp(cl_object strm) cl_object si_copy_stream(cl_object in, cl_object out) { - ecl_character c; - for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { - ecl_write_char(c, out); - } - ecl_force_output(out); - @(return ECL_T) + ecl_character c; + for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { + ecl_write_char(c, out); + } + ecl_force_output(out); + @(return ECL_T) } @@ -4999,219 +4999,219 @@ si_copy_stream(cl_object in, cl_object out) cl_fixnum ecl_normalize_stream_element_type(cl_object element_type) { - cl_fixnum sign = 0; - cl_index size; - if (element_type == @'signed-byte' || element_type == @'ext::integer8') { - return -8; - } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { - return 8; - } else if (element_type == @':default') { - return 0; + cl_fixnum sign = 0; + cl_index size; + if (element_type == @'signed-byte' || element_type == @'ext::integer8') { + return -8; + } else if (element_type == @'unsigned-byte' || element_type == @'ext::byte8') { + return 8; + } else if (element_type == @':default') { + return 0; } else if (element_type == @'base-char' || element_type == @'character') { return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { - return 0; - } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { - sign = +1; - } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { - sign = -1; - } else { - FEerror("Not a valid stream element type: ~A", 1, element_type); - } - if (CONSP(element_type)) { - if (CAR(element_type) == @'unsigned-byte') - return ecl_to_size(cl_cadr(element_type)); - if (CAR(element_type) == @'signed-byte') - return -ecl_to_size(cl_cadr(element_type)); - } - for (size = 8; 1; size++) { - cl_object type; - type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', - ecl_make_fixnum(size)); - if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { - return size * sign; - } - } - FEerror("Not a valid stream element type: ~A", 1, element_type); + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') != ECL_NIL) { + return 0; + } else if (_ecl_funcall3(@'subtypep', element_type, @'unsigned-byte') != ECL_NIL) { + sign = +1; + } else if (_ecl_funcall3(@'subtypep', element_type, @'signed-byte') != ECL_NIL) { + sign = -1; + } else { + FEerror("Not a valid stream element type: ~A", 1, element_type); + } + if (CONSP(element_type)) { + if (CAR(element_type) == @'unsigned-byte') + return ecl_to_size(cl_cadr(element_type)); + if (CAR(element_type) == @'signed-byte') + return -ecl_to_size(cl_cadr(element_type)); + } + for (size = 8; 1; size++) { + cl_object type; + type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', + ecl_make_fixnum(size)); + if (_ecl_funcall3(@'subtypep', element_type, type) != ECL_NIL) { + return size * sign; + } + } + FEerror("Not a valid stream element type: ~A", 1, element_type); } static void FEinvalid_option(cl_object option, cl_object value) { - FEerror("Invalid value op option ~A: ~A", 2, option, value); + FEerror("Invalid value op option ~A: ~A", 2, option, value); } cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, - cl_object if_does_not_exist, cl_fixnum byte_size, - int flags, cl_object external_format) + cl_object if_does_not_exist, cl_fixnum byte_size, + int flags, cl_object external_format) { - cl_object output; - int f; + cl_object output; + int f; #if defined(ECL_MS_WINDOWS_HOST) ecl_mode_t mode = _S_IREAD | _S_IWRITE; #else - ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; + ecl_mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; #endif - cl_object filename = si_coerce_to_filename(fn); - char *fname = (char*)filename->base_string.self; - bool appending = 0; - bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; - if (smm == ecl_smm_input || smm == ecl_smm_probe) { - if (!exists) { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, O_WRONLY|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - safe_close(f); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - f = safe_open(fname, O_RDONLY, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (smm == ecl_smm_output || smm == ecl_smm_io) { - int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; - if (if_exists == @':new_version' && - if_does_not_exist == @':create') { - exists = 0; - if_does_not_exist = @':create'; - } - if (exists) { - if (if_exists == @':error') { - FEcannot_open(fn); - } else if (if_exists == @':rename') { - f = ecl_backup_open(fname, base|O_CREAT, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':rename_and_delete' || - if_exists == @':new_version' || - if_exists == @':supersede') { - f = safe_open(fname, base|O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (if_exists == @':overwrite' || if_exists == @':append') { - f = safe_open(fname, base, mode); - unlikely_if (f < 0) FEcannot_open(fn); - appending = (if_exists == @':append'); - } else if (Null(if_exists)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-exists', if_exists); - } - } else { - if (if_does_not_exist == @':error') { - FEcannot_open(fn); - } else if (if_does_not_exist == @':create') { - f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); - unlikely_if (f < 0) FEcannot_open(fn); - } else if (Null(if_does_not_exist)) { - return ECL_NIL; - } else { - FEinvalid_option(@':if-does-not-exist', - if_does_not_exist); - } - } - } else { - FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); - } - if (flags & ECL_STREAM_C_STREAM) { - FILE *fp; - safe_close(f); - /* We do not use fdopen() because Windows seems to - * have problems with the resulting streams. Furthermore, even for - * output we open with w+ because we do not want to - * overwrite the file. */ - switch (smm) { - case ecl_smm_probe: - case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; - case ecl_smm_output: - case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; + cl_object filename = si_coerce_to_filename(fn); + char *fname = (char*)filename->base_string.self; + bool appending = 0; + bool exists = si_file_kind(filename, ECL_T) != ECL_NIL; + if (smm == ecl_smm_input || smm == ecl_smm_probe) { + if (!exists) { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, O_WRONLY|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + safe_close(f); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + f = safe_open(fname, O_RDONLY, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (smm == ecl_smm_output || smm == ecl_smm_io) { + int base = (smm == ecl_smm_output)? O_WRONLY : O_RDWR; + if (if_exists == @':new_version' && + if_does_not_exist == @':create') { + exists = 0; + if_does_not_exist = @':create'; + } + if (exists) { + if (if_exists == @':error') { + FEcannot_open(fn); + } else if (if_exists == @':rename') { + f = ecl_backup_open(fname, base|O_CREAT, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':rename_and_delete' || + if_exists == @':new_version' || + if_exists == @':supersede') { + f = safe_open(fname, base|O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (if_exists == @':overwrite' || if_exists == @':append') { + f = safe_open(fname, base, mode); + unlikely_if (f < 0) FEcannot_open(fn); + appending = (if_exists == @':append'); + } else if (Null(if_exists)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-exists', if_exists); + } + } else { + if (if_does_not_exist == @':error') { + FEcannot_open(fn); + } else if (if_does_not_exist == @':create') { + f = safe_open(fname, base | O_CREAT | O_TRUNC, mode); + unlikely_if (f < 0) FEcannot_open(fn); + } else if (Null(if_does_not_exist)) { + return ECL_NIL; + } else { + FEinvalid_option(@':if-does-not-exist', + if_does_not_exist); + } + } + } else { + FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); + } + if (flags & ECL_STREAM_C_STREAM) { + FILE *fp; + safe_close(f); + /* We do not use fdopen() because Windows seems to + * have problems with the resulting streams. Furthermore, even for + * output we open with w+ because we do not want to + * overwrite the file. */ + switch (smm) { + case ecl_smm_probe: + case ecl_smm_input: fp = safe_fopen(fname, OPEN_R); break; + case ecl_smm_output: + case ecl_smm_io: fp = safe_fopen(fname, OPEN_RW); break; default:; /* never reached */ - } - output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, - external_format); - si_set_buffering_mode(output, byte_size? @':full' : @':line'); - } else { - output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, - external_format); - } - if (smm == ecl_smm_probe) { - cl_close(1, output); - } else { - output->stream.flags |= ECL_STREAM_MIGHT_SEEK; - si_set_finalizer(output, ECL_T); - /* Set file pointer to the correct position */ - ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); - } - return output; + } + output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, + external_format); + si_set_buffering_mode(output, byte_size? @':full' : @':line'); + } else { + output = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags, + external_format); + } + if (smm == ecl_smm_probe) { + cl_close(1, output); + } else { + output->stream.flags |= ECL_STREAM_MIGHT_SEEK; + si_set_finalizer(output, ECL_T); + /* Set file pointer to the correct position */ + ecl_file_position_set(output, appending? ECL_NIL : ecl_make_fixnum(0)); + } + return output; } @(defun open (filename - &key (direction @':input') - (element_type @'character') - (if_exists ECL_NIL iesp) - (if_does_not_exist ECL_NIL idnesp) + &key (direction @':input') + (element_type @'character') + (if_exists ECL_NIL iesp) + (if_does_not_exist ECL_NIL idnesp) (external_format @':default') - (cstream ECL_T) - &aux strm) - enum ecl_smmode smm; - int flags = 0; - cl_fixnum byte_size; + (cstream ECL_T) + &aux strm) + enum ecl_smmode smm; + int flags = 0; + cl_fixnum byte_size; @ - /* INV: ecl_open_stream() checks types */ - if (direction == @':input') { - smm = ecl_smm_input; - if (!idnesp) - if_does_not_exist = @':error'; - } else if (direction == @':output') { - smm = ecl_smm_output; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':io') { - smm = ecl_smm_io; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':probe') { - smm = ecl_smm_probe; - if (!idnesp) - if_does_not_exist = ECL_NIL; - } else { - FEerror("~S is an illegal DIRECTION for OPEN.", - 1, direction); - } - byte_size = ecl_normalize_stream_element_type(element_type); - if (byte_size != 0) { - external_format = ECL_NIL; - } - if (!Null(cstream)) { - flags |= ECL_STREAM_C_STREAM; - } - strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, - byte_size, flags, external_format); - @(return strm) + /* INV: ecl_open_stream() checks types */ + if (direction == @':input') { + smm = ecl_smm_input; + if (!idnesp) + if_does_not_exist = @':error'; + } else if (direction == @':output') { + smm = ecl_smm_output; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':io') { + smm = ecl_smm_io; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':probe') { + smm = ecl_smm_probe; + if (!idnesp) + if_does_not_exist = ECL_NIL; + } else { + FEerror("~S is an illegal DIRECTION for OPEN.", + 1, direction); + } + byte_size = ecl_normalize_stream_element_type(element_type); + if (byte_size != 0) { + external_format = ECL_NIL; + } + if (!Null(cstream)) { + flags |= ECL_STREAM_C_STREAM; + } + strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, + byte_size, flags, external_format); + @(return strm) @) @(defun close (strm &key (abort @'nil')) @ - @(return stream_dispatch_table(strm)->close(strm)); + @(return stream_dispatch_table(strm)->close(strm)); @) /********************************************************************** @@ -5223,190 +5223,190 @@ file_listen(cl_object stream, int fileno) { #if !defined(ECL_MS_WINDOWS_HOST) # if defined(HAVE_SELECT) - fd_set fds; - int retv; - struct timeval tv = { 0, 0 }; + fd_set fds; + int retv; + struct timeval tv = { 0, 0 }; /* * Note that the following code is fragile. If the file is closed (/dev/null) * then select() may return 1 (at least on OS X), so that we return a flag * saying characters are available but will find none to read. See also the * code in cl_clear_input(). */ - FD_ZERO(&fds); - FD_SET(fileno, &fds); - retv = select(fileno + 1, &fds, NULL, NULL, &tv); - if (ecl_unlikely(retv < 0)) - file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); - else if (retv > 0) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_NO_CHAR; + FD_ZERO(&fds); + FD_SET(fileno, &fds); + retv = select(fileno + 1, &fds, NULL, NULL, &tv); + if (ecl_unlikely(retv < 0)) + file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0); + else if (retv > 0) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_NO_CHAR; # elif defined(FIONREAD) - { - long c = 0; - ioctl(fileno, FIONREAD, &c); - return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; - } + { + long c = 0; + ioctl(fileno, FIONREAD, &c); + return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; + } # endif /* FIONREAD */ #else - HANDLE hnd = (HANDLE)_get_osfhandle(fileno); - switch (GetFileType(hnd)) { - case FILE_TYPE_CHAR: { - DWORD dw, dw_read, cm; - if (GetNumberOfConsoleInputEvents(hnd, &dw)) { - unlikely_if (!GetConsoleMode(hnd, &cm)) - FEwin32_error("GetConsoleMode() failed", 0); - if (dw > 0) { - PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); - int i; - unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) - FEwin32_error("PeekConsoleInput failed()", 0); - if (dw_read > 0) { - if (cm & ENABLE_LINE_INPUT) { - for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); - else if (GetLastError() == ERROR_BROKEN_PIPE) - return ECL_LISTEN_EOF; - else - FEwin32_error("PeekNamedPipe() failed", 0); - break; - } - default: - FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); - break; - } + HANDLE hnd = (HANDLE)_get_osfhandle(fileno); + switch (GetFileType(hnd)) { + case FILE_TYPE_CHAR: { + DWORD dw, dw_read, cm; + if (GetNumberOfConsoleInputEvents(hnd, &dw)) { + unlikely_if (!GetConsoleMode(hnd, &cm)) + FEwin32_error("GetConsoleMode() failed", 0); + if (dw > 0) { + PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); + int i; + unlikely_if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) + FEwin32_error("PeekConsoleInput failed()", 0); + if (dw_read > 0) { + if (cm & ENABLE_LINE_INPUT) { + for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); + else if (GetLastError() == ERROR_BROKEN_PIPE) + return ECL_LISTEN_EOF; + else + FEwin32_error("PeekNamedPipe() failed", 0); + break; + } + default: + FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd))); + break; + } #endif - return -3; + return -3; } static int flisten(cl_object stream, FILE *fp) { - int aux; - if (feof(fp)) - return ECL_LISTEN_EOF; + int aux; + if (feof(fp)) + return ECL_LISTEN_EOF; #ifdef FILE_CNT - if (FILE_CNT(fp) > 0) - return ECL_LISTEN_AVAILABLE; + if (FILE_CNT(fp) > 0) + return ECL_LISTEN_AVAILABLE; #endif - aux = file_listen(stream, fileno(fp)); - if (aux != -3) - return aux; - /* This code is portable, and implements the expected behavior for regular files. - It will fail on noninteractive streams. */ - { - /* regular file */ - ecl_off_t old_pos = ecl_ftello(fp), end_pos; - unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - end_pos = ecl_ftello(fp); - unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) - file_libc_error(@[file-error], stream, - "Unable to check file position", 0); - return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); - } - return !ECL_LISTEN_AVAILABLE; + aux = file_listen(stream, fileno(fp)); + if (aux != -3) + return aux; + /* This code is portable, and implements the expected behavior for regular files. + It will fail on noninteractive streams. */ + { + /* regular file */ + ecl_off_t old_pos = ecl_ftello(fp), end_pos; + unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + end_pos = ecl_ftello(fp); + unlikely_if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) + file_libc_error(@[file-error], stream, + "Unable to check file position", 0); + return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); + } + return !ECL_LISTEN_AVAILABLE; } cl_object ecl_off_t_to_integer(ecl_off_t offset) { - cl_object output; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = ecl_make_integer(offset); - } else if (offset <= MOST_POSITIVE_FIXNUM) { - output = ecl_make_fixnum((cl_fixnum)offset); - } else { - cl_object y = _ecl_big_register0(); - if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { - ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; - offset >>= FIXNUM_BITS; - ECL_BIGNUM_LIMBS(y)[1] = offset; - ECL_BIGNUM_SIZE(y) = offset? 2 : 1; - } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { - ECL_BIGNUM_LIMBS(y)[0] = offset; - ECL_BIGNUM_SIZE(y) = 1; - } - output = _ecl_big_register_normalize(y); - } - return output; + cl_object output; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = ecl_make_integer(offset); + } else if (offset <= MOST_POSITIVE_FIXNUM) { + output = ecl_make_fixnum((cl_fixnum)offset); + } else { + cl_object y = _ecl_big_register0(); + if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) == sizeof(cl_index)) { + ECL_BIGNUM_LIMBS(y)[0] = (cl_index)offset; + offset >>= FIXNUM_BITS; + ECL_BIGNUM_LIMBS(y)[1] = offset; + ECL_BIGNUM_SIZE(y) = offset? 2 : 1; + } else if (sizeof(ECL_BIGNUM_LIMBS(y)[0]) >= sizeof(ecl_off_t)) { + ECL_BIGNUM_LIMBS(y)[0] = offset; + ECL_BIGNUM_SIZE(y) = 1; + } + output = _ecl_big_register_normalize(y); + } + return output; } ecl_off_t ecl_integer_to_off_t(cl_object offset) { - ecl_off_t output = 0; - if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { - output = fixint(offset); - } else if (ECL_FIXNUMP(offset)) { - output = fixint(offset); - } else if (ECL_BIGNUMP(offset)) { - if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { - if (ECL_BIGNUM_SIZE(offset) > 2) { - goto ERR; - } - if (ECL_BIGNUM_SIZE(offset) == 2) { - output = ECL_BIGNUM_LIMBS(offset)[1]; - output <<= FIXNUM_BITS; - } - output += ECL_BIGNUM_LIMBS(offset)[0]; - } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { - if (ECL_BIGNUM_SIZE(offset) > 1) { - goto ERR; - } - output = ECL_BIGNUM_LIMBS(offset)[0]; - } - } else { - ERR: FEerror("Not a valid file offset: ~S", 1, offset); - } - return output; + ecl_off_t output = 0; + if (sizeof(ecl_off_t) == sizeof(cl_fixnum)) { + output = fixint(offset); + } else if (ECL_FIXNUMP(offset)) { + output = fixint(offset); + } else if (ECL_BIGNUMP(offset)) { + if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) == sizeof(cl_index)) { + if (ECL_BIGNUM_SIZE(offset) > 2) { + goto ERR; + } + if (ECL_BIGNUM_SIZE(offset) == 2) { + output = ECL_BIGNUM_LIMBS(offset)[1]; + output <<= FIXNUM_BITS; + } + output += ECL_BIGNUM_LIMBS(offset)[0]; + } else if (sizeof(ECL_BIGNUM_LIMBS(offset)[0]) >= sizeof(ecl_off_t)) { + if (ECL_BIGNUM_SIZE(offset) > 1) { + goto ERR; + } + output = ECL_BIGNUM_LIMBS(offset)[0]; + } + } else { + ERR: FEerror("Not a valid file offset: ~S", 1, offset); + } + return output; } static cl_object alloc_stream() { - cl_object x = ecl_alloc_object(t_stream); - x->stream.closed = 0; - x->stream.file.descriptor = -1; - x->stream.object0 = - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - x->stream.format = ECL_NIL; - x->stream.flags = 0; - x->stream.byte_size = 8; - x->stream.buffer = NULL; - x->stream.encoder = NULL; - x->stream.decoder = NULL; - x->stream.last_char = EOF; - x->stream.byte_stack = ECL_NIL; - x->stream.last_code[0] = x->stream.last_code[1] = EOF; - x->stream.eof_char = EOF; - return x; + cl_object x = ecl_alloc_object(t_stream); + x->stream.closed = 0; + x->stream.file.descriptor = -1; + x->stream.object0 = + x->stream.object1 = OBJNULL; + x->stream.int0 = x->stream.int1 = 0; + x->stream.format = ECL_NIL; + x->stream.flags = 0; + x->stream.byte_size = 8; + x->stream.buffer = NULL; + x->stream.encoder = NULL; + x->stream.decoder = NULL; + x->stream.last_char = EOF; + x->stream.byte_stack = ECL_NIL; + x->stream.last_code[0] = x->stream.last_code[1] = EOF; + x->stream.eof_char = EOF; + return x; } /********************************************************************** @@ -5416,131 +5416,131 @@ alloc_stream() static cl_object not_a_file_stream(cl_object strm) { - return cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an file stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', @'file-stream', - @':datum', strm); + return cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an file stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', @'file-stream', + @':datum', strm); } static void not_an_input_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an input stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', - cl_list(2, @'satisfies', @'input-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an input stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', + cl_list(2, @'satisfies', @'input-stream-p'), + @':datum', strm); } static void not_an_output_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not an output stream"), - @':format-arguments', cl_list(1, strm), - @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), - @':datum', strm); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an output stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), + @':datum', strm); } static void not_a_character_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a character stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'character', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a character stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'character', + @':datum', cl_stream_element_type(s)); } static void not_a_binary_stream(cl_object s) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~A is not a binary stream"), - @':format-arguments', cl_list(1, s), - @':expected-type', @'integer', - @':datum', cl_stream_element_type(s)); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a binary stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'integer', + @':datum', cl_stream_element_type(s)); } static void cannot_close(cl_object stream) { - file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); + file_libc_error(@[file-error], stream, "Stream cannot be closed", 0); } static void file_libc_error(cl_object error_type, cl_object stream, - const char *msg, int narg, ...) + const char *msg, int narg, ...) { - ecl_va_list args; - cl_object rest, error = _ecl_strerror(errno); + ecl_va_list args; + cl_object rest, error = _ecl_strerror(errno); - ecl_va_start(args, narg, narg, 0); - rest = cl_grab_rest_args(args); + ecl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); - si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, - make_constant_base_string("~?~%C library explanation: ~A."), - cl_list(3, make_constant_base_string(msg), rest, - error)); + si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, + make_constant_base_string("~?~%C library explanation: ~A."), + cl_list(3, make_constant_base_string(msg), rest, + error)); } static void unread_error(cl_object s) { - CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); + CEerror(ECL_T, "Error when using UNREAD-CHAR on stream ~D", 1, s); } static void unread_twice(cl_object s) { - CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); + CEerror(ECL_T, "Used UNREAD-CHAR twice on stream ~D", 1, s); } static void maybe_clearerr(cl_object strm) { - int t = strm->stream.mode; - if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { - FILE *f = IO_STREAM_FILE(strm); - if (f != NULL) clearerr(f); - } + int t = strm->stream.mode; + if (t == ecl_smm_io || t == ecl_smm_output || t == ecl_smm_input) { + FILE *f = IO_STREAM_FILE(strm); + if (f != NULL) clearerr(f); + } } static int restartable_io_error(cl_object strm, const char *s) { - cl_env_ptr the_env = ecl_process_env(); - volatile int old_errno = errno; - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - if (old_errno == EINTR) { - return 1; - } else { - file_libc_error(@[stream-error], strm, - "C operation (~A) signaled an error.", - 1, ecl_make_constant_base_string(s, strlen(s))); - return 0; - } + cl_env_ptr the_env = ecl_process_env(); + volatile int old_errno = errno; + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + if (old_errno == EINTR) { + return 1; + } else { + file_libc_error(@[stream-error], strm, + "C operation (~A) signaled an error.", + 1, ecl_make_constant_base_string(s, strlen(s))); + return 0; + } } static void io_error(cl_object strm) { - cl_env_ptr the_env = ecl_process_env(); - /* ecl_disable_interrupts(); ** done by caller */ - maybe_clearerr(strm); - ecl_enable_interrupts_env(the_env); - file_libc_error(@[stream-error], strm, - "Read or write operation signaled an error", 0); + cl_env_ptr the_env = ecl_process_env(); + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + file_libc_error(@[stream-error], strm, + "Read or write operation signaled an error", 0); } static void wrong_file_handler(cl_object strm) { - FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); + FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm); } #ifdef ECL_UNICODE @@ -5548,8 +5548,8 @@ static cl_index encoding_error(cl_object stream, unsigned char *buffer, ecl_character c) { cl_object code = _ecl_funcall4(@'ext::encoding-error', stream, - cl_stream_external_format(stream), - ecl_make_integer(c)); + cl_stream_external_format(stream), + ecl_make_integer(c)); if (Null(code)) { /* Output nothing */ return 0; @@ -5567,8 +5567,8 @@ decoding_error(cl_object stream, unsigned char *buffer, int length) octets = CONS(ecl_make_fixnum(buffer[--length]), octets); } code = _ecl_funcall4(@'ext::decoding-error', stream, - cl_stream_external_format(stream), - octets); + cl_stream_external_format(stream), + octets); if (Null(code)) { /* Go for next character */ return stream->stream.decoder(stream); @@ -5583,85 +5583,85 @@ decoding_error(cl_object stream, unsigned char *buffer, int length) static void wsock_error( const char *err_msg, cl_object strm ) { - char *msg; - cl_object msg_obj; - /* ecl_disable_interrupts(); ** done by caller */ - { - FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); - msg_obj = make_base_string_copy( msg ); - LocalFree( msg ); - } - ecl_enable_interrupts(); - FEerror( err_msg, 2, strm, msg_obj ); + char *msg; + cl_object msg_obj; + /* ecl_disable_interrupts(); ** done by caller */ + { + FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); + msg_obj = make_base_string_copy( msg ); + LocalFree( msg ); + } + ecl_enable_interrupts(); + FEerror( err_msg, 2, strm, msg_obj ); } #endif void init_file(void) { - int flags; - cl_object standard_input; - cl_object standard_output; - cl_object error_output; - cl_object aux; - cl_object null_stream; - cl_object external_format = ECL_NIL; + int flags; + cl_object standard_input; + cl_object standard_output; + cl_object error_output; + cl_object aux; + cl_object null_stream; + cl_object external_format = ECL_NIL; #if defined(ECL_MS_WINDOWS_HOST) # ifdef ECL_UNICODE - external_format = cl_list(2, @':latin-1', @':crlf'); - flags = 0; + external_format = cl_list(2, @':latin-1', @':crlf'); + flags = 0; # else - external_format = cl_list(2, @':crlf', @':pass-through'); - flags = ECL_STREAM_DEFAULT_FORMAT; + external_format = cl_list(2, @':crlf', @':pass-through'); + flags = ECL_STREAM_DEFAULT_FORMAT; # endif #else - flags = ECL_STREAM_DEFAULT_FORMAT; + flags = ECL_STREAM_DEFAULT_FORMAT; #endif - null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), - NULL, ecl_smm_io, 8, flags, external_format); - generic_close(null_stream); - null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); - cl_core.null_stream = null_stream; + null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), + NULL, ecl_smm_io, 8, flags, external_format); + generic_close(null_stream); + null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); + cl_core.null_stream = null_stream; /* We choose C streams by default only when _not_ using threads. * The reason is that C streams block on I/O operations. */ #if !defined(ECL_THREADS) - standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), - stdin, ecl_smm_input, 8, flags, external_format); - standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), - stdout, ecl_smm_output, 8, flags, external_format); - error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), - stderr, ecl_smm_output, 8, flags, external_format); + standard_input = maybe_make_windows_console_FILE(make_constant_base_string("stdin"), + stdin, ecl_smm_input, 8, flags, external_format); + standard_output = maybe_make_windows_console_FILE(make_constant_base_string("stdout"), + stdout, ecl_smm_output, 8, flags, external_format); + error_output = maybe_make_windows_console_FILE(make_constant_base_string("stderr"), + stderr, ecl_smm_output, 8, flags, external_format); #else - standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), - STDIN_FILENO, ecl_smm_input_file, 8, flags, - external_format); - standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), - STDOUT_FILENO, ecl_smm_output_file, 8, flags, - external_format); - error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), - STDERR_FILENO, ecl_smm_output_file, 8, flags, - external_format); + standard_input = maybe_make_windows_console_fd(make_constant_base_string("stdin"), + STDIN_FILENO, ecl_smm_input_file, 8, flags, + external_format); + standard_output = maybe_make_windows_console_fd(make_constant_base_string("stdout"), + STDOUT_FILENO, ecl_smm_output_file, 8, flags, + external_format); + error_output = maybe_make_windows_console_fd(make_constant_base_string("stderr"), + STDERR_FILENO, ecl_smm_output_file, 8, flags, + external_format); #endif - cl_core.standard_input = standard_input; + cl_core.standard_input = standard_input; ECL_SET(@'ext::+process-standard-input+', standard_input); - ECL_SET(@'*standard-input*', standard_input); - cl_core.standard_output = standard_output; + ECL_SET(@'*standard-input*', standard_input); + cl_core.standard_output = standard_output; ECL_SET(@'ext::+process-standard-output+', standard_output); - ECL_SET(@'*standard-output*', standard_output); - ECL_SET(@'*trace-output*', standard_output); - cl_core.error_output = error_output; + ECL_SET(@'*standard-output*', standard_output); + ECL_SET(@'*trace-output*', standard_output); + cl_core.error_output = error_output; ECL_SET(@'ext::+process-error-output+', error_output); - ECL_SET(@'*error-output*', error_output); + ECL_SET(@'*error-output*', error_output); - cl_core.terminal_io = aux - = cl_make_two_way_stream(standard_input, standard_output); + cl_core.terminal_io = aux + = cl_make_two_way_stream(standard_input, standard_output); - ECL_SET(@'*terminal-io*', aux); - aux = cl_make_synonym_stream(@'*terminal-io*'); - ECL_SET(@'*query-io*', aux); - ECL_SET(@'*debug-io*', aux); + ECL_SET(@'*terminal-io*', aux); + aux = cl_make_synonym_stream(@'*terminal-io*'); + ECL_SET(@'*query-io*', aux); + ECL_SET(@'*debug-io*', aux); } diff --git a/src/c/format.d b/src/c/format.d index 9f9fc31d6..e463a1cc1 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -27,20 +27,20 @@ #warning "The old version of FORMAT is not ANSI compliant" -#define FMT_MAX_PARAM 8 +#define FMT_MAX_PARAM 8 typedef struct format_stack_struct { - cl_object stream; - cl_object aux_stream; - cl_object aux_string; - cl_index ctl_index, ctl_end; - cl_object ctl_str; - cl_object args, current; - jmp_buf *jmp_buf; - cl_index indents; - cl_index spare_spaces; - cl_index line_length; + cl_object stream; + cl_object aux_stream; + cl_object aux_string; + cl_index ctl_index, ctl_end; + cl_object ctl_str; + cl_object args, current; + jmp_buf *jmp_buf; + cl_index indents; + cl_index spare_spaces; + cl_index line_length; cl_object param[FMT_MAX_PARAM]; - int nparam; + int nparam; } *format_stack; #if MOST_POSITIVE_FIXNUM_VAL < INT_MAX @@ -58,38 +58,38 @@ typedef struct format_stack_struct { /******************* COMMON ***************************/ -#define NONE 0 -#define INT 1 -#define CHAR 2 +#define NONE 0 +#define INT 1 +#define CHAR 2 static const char *fmt_big_numeral[] = { - "thousand", - "million", - "billion", - "trillion", - "quadrillion", - "quintillion", - "sextillion", - "septillion", - "octillion" + "thousand", + "million", + "billion", + "trillion", + "quadrillion", + "quintillion", + "sextillion", + "septillion", + "octillion" }; static const char *fmt_numeral[] = { - "zero", "one", "two", "three", "four", - "five", "six", "seven", "eight", "nine", - "ten", "eleven", "twelve", "thirteen", "fourteen", - "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", - "zero", "ten", "twenty", "thirty", "forty", - "fifty", "sixty", "seventy", "eighty", "ninety" + "zero", "one", "two", "three", "four", + "five", "six", "seven", "eight", "nine", + "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", + "zero", "ten", "twenty", "thirty", "forty", + "fifty", "sixty", "seventy", "eighty", "ninety" }; static const char *fmt_ordinal[] = { - "zeroth", "first", "second", "third", "fourth", - "fifth", "sixth", "seventh", "eighth", "ninth", - "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", - "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", - "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", - "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" + "zeroth", "first", "second", "third", "fourth", + "fifth", "sixth", "seventh", "eighth", "ninth", + "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", + "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", + "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", + "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" }; static void format(format_stack, cl_index, cl_index); @@ -98,644 +98,644 @@ static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va static cl_object get_aux_stream(void) { - cl_env_ptr env = ecl_process_env(); - cl_object stream; + cl_env_ptr env = ecl_process_env(); + cl_object stream; - ecl_disable_interrupts_env(env); - if (env->fmt_aux_stream == ECL_NIL) { - stream = ecl_make_string_output_stream(64, 1); - } else { - stream = env->fmt_aux_stream; - env->fmt_aux_stream = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return stream; + ecl_disable_interrupts_env(env); + if (env->fmt_aux_stream == ECL_NIL) { + stream = ecl_make_string_output_stream(64, 1); + } else { + stream = env->fmt_aux_stream; + env->fmt_aux_stream = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return stream; } static void fmt_error(format_stack fmt, const char *s) { - cl_error(7, @'si::format-error', - @':format-control', make_constant_base_string(s), - @':control-string', fmt->ctl_str, - @':offset', ecl_make_fixnum(fmt->ctl_index)); + cl_error(7, @'si::format-error', + @':format-control', make_constant_base_string(s), + @':control-string', fmt->ctl_str, + @':offset', ecl_make_fixnum(fmt->ctl_index)); } static ecl_character tempstr(format_stack fmt, int s) { - return ecl_char(fmt->aux_string,s); + return ecl_char(fmt->aux_string,s); } static ecl_character ctl_advance(format_stack fmt) { - if (fmt->ctl_index >= fmt->ctl_end) - fmt_error(fmt, "unexpected end of control string"); - return ecl_char(fmt->ctl_str, fmt->ctl_index++); + if (fmt->ctl_index >= fmt->ctl_end) + fmt_error(fmt, "unexpected end of control string"); + return ecl_char(fmt->ctl_str, fmt->ctl_index++); } static void fmt_go(format_stack fmt, cl_fixnum n) { - cl_object p; - if (n < 0) - fmt_error(fmt, "can't goto"); - if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) - fmt_error(fmt, "can't goto"); - fmt->current = p; + cl_object p; + if (n < 0) + fmt_error(fmt, "can't goto"); + if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL) + fmt_error(fmt, "can't goto"); + fmt->current = p; } static cl_index fmt_index(format_stack fmt) { - cl_object p = fmt->args, target = fmt->current; - cl_index n = 0; - if (target == ECL_NIL) - return ecl_length(p); - while (p != fmt->current) { - p = CDR(p); - if (p == ECL_NIL) - fmt_error(fmt, "Overflow"); - n++; - } - return n; + cl_object p = fmt->args, target = fmt->current; + cl_index n = 0; + if (target == ECL_NIL) + return ecl_length(p); + while (p != fmt->current) { + p = CDR(p); + if (p == ECL_NIL) + fmt_error(fmt, "Overflow"); + n++; + } + return n; } static cl_object fmt_back_up(format_stack fmt) { - fmt_go(fmt, fmt_index(fmt) - 1); + fmt_go(fmt, fmt_index(fmt) - 1); } static bool fmt_more_args_p(format_stack fmt) { - return fmt->current != ECL_NIL; + return fmt->current != ECL_NIL; } static cl_index fmt_args_left(format_stack fmt) { - return ecl_length(fmt->current); + return ecl_length(fmt->current); } static cl_object fmt_advance(format_stack fmt) { - cl_object output, l = fmt->current; - if (l == ECL_NIL) - fmt_error(fmt, "arguments exhausted"); - output = CAR(l); - fmt->current = CDR(l); - return output; + cl_object output, l = fmt->current; + if (l == ECL_NIL) + fmt_error(fmt, "arguments exhausted"); + output = CAR(l); + fmt->current = CDR(l); + return output; } static void fmt_set_arg_list(format_stack fmt, cl_object l) { - assert_type_proper_list(l); - fmt->current = fmt->args = cl_copy_list(l); + assert_type_proper_list(l); + fmt->current = fmt->args = cl_copy_list(l); } static int fmt_skip(format_stack fmt) { - ecl_character c; - int level = 0; + ecl_character c; + int level = 0; LOOP: - if (ctl_advance(fmt) != '~') - goto LOOP; - for (;;) - switch (c = ctl_advance(fmt)) { - case '\'': - ctl_advance(fmt); + if (ctl_advance(fmt) != '~') + goto LOOP; + for (;;) + switch (c = ctl_advance(fmt)) { + case '\'': + ctl_advance(fmt); - case ',': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - case '+': - case '-': - case 'v': case 'V': - case '#': - case ':': case '@@': - continue; + case ',': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '+': + case '-': + case 'v': case 'V': + case '#': + case ':': case '@@': + continue; - default: - goto DIRECTIVE; - } + default: + goto DIRECTIVE; + } DIRECTIVE: - switch (c) { - case '(': case '[': case '<': case '{': - level++; - break; + switch (c) { + case '(': case '[': case '<': case '{': + level++; + break; - case ')': case ']': case '>': case '}': - if (level == 0) - return(fmt->ctl_index); - else - --level; - break; + case ')': case ']': case '>': case '}': + if (level == 0) + return(fmt->ctl_index); + else + --level; + break; - case ';': - if (level == 0) - return(fmt->ctl_index); - break; - } - goto LOOP; + case ';': + if (level == 0) + return(fmt->ctl_index); + break; + } + goto LOOP; } static void ensure_param(format_stack fmt, int n) { - if (fmt->nparam > n) - fmt_error(fmt, "too many parameters"); - while (n-- > fmt->nparam) - fmt->param[n] = ECL_NIL; + if (fmt->nparam > n) + fmt_error(fmt, "too many parameters"); + while (n-- > fmt->nparam) + fmt->param[n] = ECL_NIL; } static void fmt_not_colon(format_stack fmt, bool colon) { - if (colon) - fmt_error(fmt, "illegal :"); + if (colon) + fmt_error(fmt, "illegal :"); } static void fmt_not_atsign(format_stack fmt, bool atsign) { - if (atsign) - fmt_error(fmt, "illegal @@"); + if (atsign) + fmt_error(fmt, "illegal @@"); } static void fmt_not_colon_atsign(format_stack fmt, bool colon, bool atsign) { - if (colon && atsign) - fmt_error(fmt, "illegal :@@"); + if (colon && atsign) + fmt_error(fmt, "illegal :@@"); } static cl_object set_param(format_stack fmt, int i, int t, cl_object v) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return v; - else if ((t != INT && t != CHAR) || - (t == INT && !cl_integerp(fmt->param[i])) || - (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) - fmt_error(fmt, "illegal parameter type"); - return fmt->param[i]; + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return v; + else if ((t != INT && t != CHAR) || + (t == INT && !cl_integerp(fmt->param[i])) || + (t == CHAR && !ECL_CHARACTERP(fmt->param[i]))) + fmt_error(fmt, "illegal parameter type"); + return fmt->param[i]; } static int set_param_positive(format_stack fmt, int i, const char *message) { - if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) - return -1; - else if (cl_integerp(fmt->param[i]) == ECL_NIL) - fmt_error(fmt, "illegal parameter type"); - else { - cl_object p = fmt->param[i]; - if (ecl_minusp(p)) fmt_error(fmt, message); - return ecl_to_fix(p); - } + if (i >= fmt->nparam || fmt->param[i] == ECL_NIL) + return -1; + else if (cl_integerp(fmt->param[i]) == ECL_NIL) + fmt_error(fmt, "illegal parameter type"); + else { + cl_object p = fmt->param[i]; + if (ecl_minusp(p)) fmt_error(fmt, message); + return ecl_to_fix(p); + } } static void fmt_copy(format_stack fmt_copy, format_stack fmt) { - *fmt_copy = *fmt; + *fmt_copy = *fmt; } static void fmt_copy1(format_stack fmt_copy, format_stack fmt) { - fmt_copy->stream = fmt->stream; - fmt_copy->ctl_str = fmt->ctl_str; - fmt_copy->ctl_index = fmt->ctl_index; - fmt_copy->ctl_end = fmt->ctl_end; - fmt_copy->jmp_buf = fmt->jmp_buf; - fmt_copy->indents = fmt->indents; + fmt_copy->stream = fmt->stream; + fmt_copy->ctl_str = fmt->ctl_str; + fmt_copy->ctl_index = fmt->ctl_index; + fmt_copy->ctl_end = fmt->ctl_end; + fmt_copy->jmp_buf = fmt->jmp_buf; + fmt_copy->indents = fmt->indents; } static void fmt_prepare_aux_stream(format_stack fmt) { - fmt->aux_string->base_string.fillp = 0; - fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); - fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); + fmt->aux_string->base_string.fillp = 0; + fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream); + fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream); } static void fmt_ascii(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_princ(x, fmt->stream); - return; - } else - ecl_princ(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_princ(x, fmt->stream); + return; + } else + ecl_princ(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } static void fmt_S_expression(format_stack fmt, bool colon, bool atsign) { - int mincol, colinc, minpad; - ecl_character padchar; - cl_object x; - int l, i; + int mincol, colinc, minpad; + ecl_character padchar; + cl_object x; + int l, i; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fmt_prepare_aux_stream(fmt); - x = fmt_advance(fmt); - if (colon && Null(x)) - writestr_stream("()", fmt->aux_stream); - else if (mincol == 0 && minpad == 0) { - ecl_prin1(x, fmt->stream); - return; - } else - ecl_prin1(x, fmt->aux_stream); - l = fmt->aux_string->base_string.fillp; - for (i = minpad; l + i < mincol; i += colinc) - ; - if (!atsign) { - ecl_write_string(fmt->aux_string, fmt->stream); - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - } else { - while (i-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - } + fmt_prepare_aux_stream(fmt); + x = fmt_advance(fmt); + if (colon && Null(x)) + writestr_stream("()", fmt->aux_stream); + else if (mincol == 0 && minpad == 0) { + ecl_prin1(x, fmt->stream); + return; + } else + ecl_prin1(x, fmt->aux_stream); + l = fmt->aux_string->base_string.fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + ecl_write_string(fmt->aux_string, fmt->stream); + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + } else { + while (i-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + } } static void fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign, - int radix, int mincol, ecl_character padchar, ecl_character commachar) + int radix, int mincol, ecl_character padchar, ecl_character commachar) { - const cl_env_ptr env = ecl_process_env(); - int l, l1; - int s; + const cl_env_ptr env = ecl_process_env(); + int l, l1; + int s; - if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = fmt->aux_string->base_string.fillp; - mincol -= l; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - ecl_write_string(fmt->aux_string, fmt->stream); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - l = l1 = fmt->aux_string->base_string.fillp; - s = 0; - if (tempstr(fmt, s) == '-') - --l1; - mincol -= l; - if (colon) - mincol -= (l1 - 1)/3; - if (atsign && tempstr(fmt, s) != '-') - --mincol; - while (mincol-- > 0) - ecl_write_char(padchar, fmt->stream); - if (tempstr(fmt, s) == '-') { - s++; - ecl_write_char('-', fmt->stream); - } else if (atsign) - ecl_write_char('+', fmt->stream); - while (l1-- > 0) { - ecl_write_char(tempstr(fmt, s++), fmt->stream); - if (colon && l1 > 0 && l1%3 == 0) - ecl_write_char(commachar, fmt->stream); - } + if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) { + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = fmt->aux_string->base_string.fillp; + mincol -= l; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + ecl_write_string(fmt->aux_string, fmt->stream); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + l = l1 = fmt->aux_string->base_string.fillp; + s = 0; + if (tempstr(fmt, s) == '-') + --l1; + mincol -= l; + if (colon) + mincol -= (l1 - 1)/3; + if (atsign && tempstr(fmt, s) != '-') + --mincol; + while (mincol-- > 0) + ecl_write_char(padchar, fmt->stream); + if (tempstr(fmt, s) == '-') { + s++; + ecl_write_char('-', fmt->stream); + } else if (atsign) + ecl_write_char('+', fmt->stream); + while (l1-- > 0) { + ecl_write_char(tempstr(fmt, s++), fmt->stream); + if (colon && l1 > 0 && l1%3 == 0) + ecl_write_char(commachar, fmt->stream); + } } static void fmt_decimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 10, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 10, mincol, padchar, commachar); } static void fmt_binary(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 2, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 2, mincol, padchar, commachar); } static void fmt_octal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 8, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 8, mincol, padchar, commachar); } static void fmt_hexadecimal(format_stack fmt, bool colon, bool atsign) { - int mincol; - ecl_character padchar, commachar; + int mincol; + ecl_character padchar, commachar; - ensure_param(fmt, 3); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); - fmt_integer(fmt, fmt_advance(fmt), colon, atsign, - 16, mincol, padchar, commachar); + ensure_param(fmt, 3); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(','))); + fmt_integer(fmt, fmt_advance(fmt), colon, atsign, + 16, mincol, padchar, commachar); } static void fmt_write_numeral(format_stack fmt, int s, int i) { - writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream); } static void fmt_write_ordinal(format_stack fmt, int s, int i) { - writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); + writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream); } static bool fmt_thousand(format_stack fmt, int s, int i, bool b, bool o, int t) { - if (i == 3 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - fmt_write_numeral(fmt, s, 0); - writestr_stream(" hundred", fmt->stream); - --i; - s++; - b = TRUE; - if (o && (s > t)) - writestr_stream("th", fmt->stream); - } - if (i == 3) { - --i; - s++; - } - if (i == 2 && tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (tempstr(fmt, s) == '1') { - if (o && (s + 2 > t)) - fmt_write_ordinal(fmt, ++s, 10); - else - fmt_write_numeral(fmt, ++s, 10); - return(TRUE); - } else { - if (o && (s + 1 > t)) - fmt_write_ordinal(fmt, s, 20); - else - fmt_write_numeral(fmt, s, 20); - s++; - if (tempstr(fmt, s) > '0') { - ecl_write_char('-', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - } - return(TRUE); - } - } - if (i == 2) - s++; - if (tempstr(fmt, s) > '0') { - if (b) - ecl_write_char(' ', fmt->stream); - if (o && s + 1 > t) - fmt_write_ordinal(fmt, s, 0); - else - fmt_write_numeral(fmt, s, 0); - return(TRUE); - } - return(b); + if (i == 3 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + fmt_write_numeral(fmt, s, 0); + writestr_stream(" hundred", fmt->stream); + --i; + s++; + b = TRUE; + if (o && (s > t)) + writestr_stream("th", fmt->stream); + } + if (i == 3) { + --i; + s++; + } + if (i == 2 && tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (tempstr(fmt, s) == '1') { + if (o && (s + 2 > t)) + fmt_write_ordinal(fmt, ++s, 10); + else + fmt_write_numeral(fmt, ++s, 10); + return(TRUE); + } else { + if (o && (s + 1 > t)) + fmt_write_ordinal(fmt, s, 20); + else + fmt_write_numeral(fmt, s, 20); + s++; + if (tempstr(fmt, s) > '0') { + ecl_write_char('-', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + } + return(TRUE); + } + } + if (i == 2) + s++; + if (tempstr(fmt, s) > '0') { + if (b) + ecl_write_char(' ', fmt->stream); + if (o && s + 1 > t) + fmt_write_ordinal(fmt, s, 0); + else + fmt_write_numeral(fmt, s, 0); + return(TRUE); + } + return(b); } static bool fmt_nonillion(format_stack fmt, int s, int i, bool b, bool o, int t) { - int j; + int j; - for (; i > 3; i -= j) { - b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); - if (j != 3 || tempstr(fmt, s) != '0' || - tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { - ecl_write_char(' ', fmt->stream); - writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], - fmt->stream); - s += j; - if (o && s > t) - writestr_stream("th", fmt->stream); - } else - s += j; - } - return(fmt_thousand(fmt, s, i, b, o, t)); + for (; i > 3; i -= j) { + b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t); + if (j != 3 || tempstr(fmt, s) != '0' || + tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') { + ecl_write_char(' ', fmt->stream); + writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], + fmt->stream); + s += j; + if (o && s > t) + writestr_stream("th", fmt->stream); + } else + s += j; + } + return(fmt_thousand(fmt, s, i, b, o, t)); } static void fmt_roman(format_stack fmt, int i, int one, int five, int ten, bool colon) { - int j; + int j; - if (i == 0) - return; - if ((!colon && i < 4) || (colon && i < 5)) - for (j = 0; j < i; j++) - ecl_write_char(one, fmt->stream); - else if (!colon && i == 4) { - ecl_write_char(one, fmt->stream); - ecl_write_char(five, fmt->stream); - } else if ((!colon && i < 9) || colon) { - ecl_write_char(five, fmt->stream); - for (j = 5; j < i; j++) - ecl_write_char(one, fmt->stream); - } else if (!colon && i == 9) { - ecl_write_char(one, fmt->stream); - ecl_write_char(ten, fmt->stream); - } + if (i == 0) + return; + if ((!colon && i < 4) || (colon && i < 5)) + for (j = 0; j < i; j++) + ecl_write_char(one, fmt->stream); + else if (!colon && i == 4) { + ecl_write_char(one, fmt->stream); + ecl_write_char(five, fmt->stream); + } else if ((!colon && i < 9) || colon) { + ecl_write_char(five, fmt->stream); + for (j = 5; j < i; j++) + ecl_write_char(one, fmt->stream); + } else if (!colon && i == 9) { + ecl_write_char(one, fmt->stream); + ecl_write_char(ten, fmt->stream); + } } static void fmt_radix(format_stack fmt, bool colon, bool atsign) { - const cl_env_ptr env = ecl_process_env(); - int radix, mincol; - ecl_character padchar, commachar; - cl_object x; - int i, j, k; - int s, t; - bool b; + const cl_env_ptr env = ecl_process_env(); + int radix, mincol; + ecl_character padchar, commachar; + cl_object x; + int i, j, k; + int s, t; + bool b; - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - assert_type_integer(x); - if (atsign) { - if (ECL_FIXNUMP(x)) - i = ecl_fixnum(x); - else - i = -1; - if ((!colon && (i <= 0 || i >= 4000)) || - (colon && (i <= 0 || i >= 5000))) { - fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); - return; - } - fmt_roman(fmt, i/1000, 'M', '*', '*', colon); - fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); - fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); - fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); - return; - } - fmt_prepare_aux_stream(fmt); - ecl_bds_bind(env, @'*print-radix*', ECL_NIL); - ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); - si_write_object(x, fmt->aux_stream); - ecl_bds_unwind_n(env, 2); - s = 0; - i = fmt->aux_string->base_string.fillp; - if (i == 1 && tempstr(fmt, s) == '0') { - writestr_stream("zero", fmt->stream); - if (colon) - writestr_stream("th", fmt->stream); - return; - } else if (tempstr(fmt, s) == '-') { - writestr_stream("minus ", fmt->stream); - --i; - s++; - } - t = fmt->aux_string->base_string.fillp; - for (; tempstr(fmt, --t) == '0' ;) ; - for (b = FALSE; i > 0; i -= j) { - b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, - i<=30&&colon, t); - s += j; - if (b && i > 30) { - for (k = (i - 1)/30; k > 0; --k) - writestr_stream(" nonillion", - fmt->stream); - if (colon && s > t) - writestr_stream("th", fmt->stream); - } - } - return; - } - ensure_param(fmt, 4); - radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); - mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); - commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); - x = fmt_advance(fmt); - assert_type_integer(x); - if (radix < 0 || radix > 36) - FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); - fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + assert_type_integer(x); + if (atsign) { + if (ECL_FIXNUMP(x)) + i = ecl_fixnum(x); + else + i = -1; + if ((!colon && (i <= 0 || i >= 4000)) || + (colon && (i <= 0 || i >= 5000))) { + fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ','); + return; + } + fmt_roman(fmt, i/1000, 'M', '*', '*', colon); + fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon); + fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon); + fmt_roman(fmt, i%10, 'I', 'V', 'X', colon); + return; + } + fmt_prepare_aux_stream(fmt); + ecl_bds_bind(env, @'*print-radix*', ECL_NIL); + ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10)); + si_write_object(x, fmt->aux_stream); + ecl_bds_unwind_n(env, 2); + s = 0; + i = fmt->aux_string->base_string.fillp; + if (i == 1 && tempstr(fmt, s) == '0') { + writestr_stream("zero", fmt->stream); + if (colon) + writestr_stream("th", fmt->stream); + return; + } else if (tempstr(fmt, s) == '-') { + writestr_stream("minus ", fmt->stream); + --i; + s++; + } + t = fmt->aux_string->base_string.fillp; + for (; tempstr(fmt, --t) == '0' ;) ; + for (b = FALSE; i > 0; i -= j) { + b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b, + i<=30&&colon, t); + s += j; + if (b && i > 30) { + for (k = (i - 1)/30; k > 0; --k) + writestr_stream(" nonillion", + fmt->stream); + if (colon && s > t) + writestr_stream("th", fmt->stream); + } + } + return; + } + ensure_param(fmt, 4); + radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10))); + mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' '))); + commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(','))); + x = fmt_advance(fmt); + assert_type_integer(x); + if (radix < 0 || radix > 36) + FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix)); + fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar); } static void fmt_plural(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - if (colon) { - fmt_back_up(fmt); - } - if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { - if (atsign) - ecl_write_char('y', fmt->stream); - } - else - if (atsign) - writestr_stream("ies", fmt->stream); - else - ecl_write_char('s', fmt->stream); + ensure_param(fmt, 0); + if (colon) { + fmt_back_up(fmt); + } + if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) { + if (atsign) + ecl_write_char('y', fmt->stream); + } + else + if (atsign) + writestr_stream("ies", fmt->stream); + else + ecl_write_char('s', fmt->stream); } static void fmt_character(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; + cl_object x; + cl_index i; - ensure_param(fmt, 0); - x = fmt_advance(fmt); - x = ecl_check_cl_type(@'format',x,t_character); - if (!colon && !atsign) { - ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); - } else { - fmt_prepare_aux_stream(fmt); - ecl_prin1(x, fmt->aux_stream); - if (!colon && atsign) - i = 0; - else - i = 2; - for (; i < fmt->aux_string->base_string.fillp; i++) - ecl_write_char(tempstr(fmt, i), fmt->stream); - } + ensure_param(fmt, 0); + x = fmt_advance(fmt); + x = ecl_check_cl_type(@'format',x,t_character); + if (!colon && !atsign) { + ecl_write_char(ECL_CHAR_CODE(x), fmt->stream); + } else { + fmt_prepare_aux_stream(fmt); + ecl_prin1(x, fmt->aux_stream); + if (!colon && atsign) + i = 0; + else + i = 2; + for (; i < fmt->aux_string->base_string.fillp; i++) + ecl_write_char(tempstr(fmt, i), fmt->stream); + } } /* The floating point precision is required to make the @@ -783,1458 +783,1458 @@ extern long double strtold(const char *nptr, char **endptr); static int edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep) { - char *exponent, buff[DBL_SIZE + 1]; - int length; + char *exponent, buff[DBL_SIZE + 1]; + int length; ECL_WITHOUT_FPE_BEGIN { - unlikely_if (isnan(d) || !isfinite(d)) { - FEerror("Can't print a non-number.", 0); + unlikely_if (isnan(d) || !isfinite(d)) { + FEerror("Can't print a non-number.", 0); } - if (n < -DBL_MAX_DIGITS) - n = DBL_MAX_DIGITS; - if (n < 0) { - DBL_TYPE aux; - n = -n; - do { - sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); - aux = strtod(buff, NULL); + if (n < -DBL_MAX_DIGITS) + n = DBL_MAX_DIGITS; + if (n < 0) { + DBL_TYPE aux; + n = -n; + do { + sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d); + aux = strtod(buff, NULL); #ifdef ECL_LONG_FLOAT - if (n < LDBL_SIG) - aux = (double) aux; + if (n < LDBL_SIG) + aux = (double) aux; #endif - if (n < DBL_SIG) - aux = (float)aux; - n++; - } while (d != aux && n <= DBL_MAX_DIGITS); - n--; - } else { - sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, - (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); - } - exponent = strchr(buff, 'e'); + if (n < DBL_SIG) + aux = (float)aux; + n++; + } while (d != aux && n <= DBL_MAX_DIGITS); + n--; + } else { + sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE, + (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d); + } + exponent = strchr(buff, 'e'); - /* Get the exponent */ - *ep = strtol(exponent+1, NULL, 10); + /* Get the exponent */ + *ep = strtol(exponent+1, NULL, 10); - /* Get the sign */ - *sp = (buff[0] == '-') ? -1 : +1; + /* Get the sign */ + *sp = (buff[0] == '-') ? -1 : +1; - /* Get the digits of the mantissa */ - buff[2] = buff[1]; + /* Get the digits of the mantissa */ + buff[2] = buff[1]; - /* Get the actual number of digits in the mantissa */ - length = exponent - (buff + 2); + /* Get the actual number of digits in the mantissa */ + length = exponent - (buff + 2); - /* The output consists of a string {d1,d2,d3,...,dn} - with all N digits of the mantissa. If we ask for more - digits than there are, the last ones are set to zero. */ - if (n <= length) { - memcpy(s, buff+2, n); - } else { - cl_index i; - memcpy(s, buff+2, length); - for (i = length; i < n; i++) - s[i] = '0'; - } - s[n] = '\0'; + /* The output consists of a string {d1,d2,d3,...,dn} + with all N digits of the mantissa. If we ask for more + digits than there are, the last ones are set to zero. */ + if (n <= length) { + memcpy(s, buff+2, n); + } else { + cl_index i; + memcpy(s, buff+2, length); + for (i = length; i < n; i++) + s[i] = '0'; + } + s[n] = '\0'; } ECL_WITHOUT_FPE_END; - return length; + return length; } static void fmt_fix_float(format_stack fmt, bool colon, bool atsign) { - int w, d, k; - ecl_character overflowchar, padchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x; - int n, m; + int w, d, k; + ecl_character overflowchar, padchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x; + int n, m; - b = buff1 + 1; + b = buff1 + 1; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 5); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 5); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' '))); - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; - else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (exp + k > 100 || exp + k < -100 || d > 100) { - ecl_prin1(x, fmt->stream); - return; - } - if (d >= 0) - m = d + exp + k + 1; - else if (w >= 0) { - if (exp + k >= 0) - m = w - 1; - else - m = w + exp + k - 2; - if (sign < 0 || atsign) - --m; - if (m == 0) - m = 1; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp += k; - j = 0; - if (exp >= 0) { - for (i = 0; i <= exp; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + d; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < (-exp) - 1 && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < (-exp) - 1; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - if (j > w && overflowchar != '\0') { - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; - } - if (j < w && d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[0] == '.') { - *--b = '0'; - j++; - } - if (d < 0 && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (exp + k > 100 || exp + k < -100 || d > 100) { + ecl_prin1(x, fmt->stream); + return; + } + if (d >= 0) + m = d + exp + k + 1; + else if (w >= 0) { + if (exp + k >= 0) + m = w - 1; + else + m = w + exp + k - 2; + if (sign < 0 || atsign) + --m; + if (m == 0) + m = 1; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp += k; + j = 0; + if (exp >= 0) { + for (i = 0; i <= exp; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + d; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < (-exp) - 1 && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < (-exp) - 1; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + if (j > w && overflowchar != '\0') { + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; + } + if (j < w && d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[0] == '.') { + *--b = '0'; + j++; + } + if (d < 0 && b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); } static int fmt_exponent_length(int e) { - int i; + int i; - if (e == 0) - return(1); - if (e < 0) - e = -e; - for (i = 0; e > 0; i++, e /= 10) - ; - return(i); + if (e == 0) + return(1); + if (e < 0) + e = -e; + for (i = 0; e > 0; i++, e /= 10) + ; + return(i); } static void fmt_exponent1(cl_object stream, int e) { - if (e == 0) - return; - fmt_exponent1(stream, e/10); - ecl_write_char('0' + e%10, stream); + if (e == 0) + return; + fmt_exponent1(stream, e/10); + ecl_write_char('0' + e%10, stream); } static void fmt_exponent(format_stack fmt, int e) { - if (e == 0) { - ecl_write_char('0', fmt->stream); - return; - } - if (e < 0) - e = -e; - fmt_exponent1(fmt->stream, e); + if (e == 0) { + ecl_write_char('0', fmt->stream); + return; + } + if (e < 0) + e = -e; + fmt_exponent1(fmt->stream, e); } static void fmt_exponential_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - double f; - int sign; - char buff[256], *b, buff1[256]; - int exp; - int i, j; - cl_object x, y; - int n, m; - cl_type t; + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + cl_object x, y; + int n, m; + cl_type t; - b = buff1 + 1; + b = buff1 + 1; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - x = fmt_advance(fmt); - if (ECL_FIXNUMP(x) || - ecl_t_of(x) == t_bignum || - ecl_t_of(x) == t_ratio) - x = ecl_make_single_float(ecl_to_float(x)); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - n = 16; - else - n = 7; - f = ecl_to_double(x); - edit_double(n, f, &sign, buff, &exp); - if (d >= 0) { - if (k > 0) { - if (!(k < d + 2)) - fmt_error(fmt, "illegal scale factor"); - m = d + 1; - } else { - if (!(k > -d)) - fmt_error(fmt, "illegal scale factor"); - m = d + k; - } - } else if (w >= 0) { - if (k > 0) - m = w - 1; - else - m = w + k - 1; - if (sign < 0 || atsign) - --m; - if (e >= 0) - m -= e + 2; - else - m -= fmt_exponent_length(e - k + 1) + 2; - } else - m = n; - if (m <= 0) { - if (m == 0 && buff[0] >= '5') { - exp++; - n = m = 1; - buff[0] = '1'; - } else - n = m = 0; - } else if (m < n) { - n = m; - edit_double(n, f, &sign, buff, &exp); - } - while (n >= 0) - if (buff[n - 1] == '0') - --n; - else - break; - exp = exp - k + 1; - j = 0; - if (k > 0) { - for (i = 0; i < k; i++) - b[j++] = i < n ? buff[i] : '0'; - b[j++] = '.'; - if (d >= 0) - for (m = i + (d - k + 1); i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - else - for (; i < n; i++) - b[j++] = buff[i]; - } else { - b[j++] = '.'; - if (d >= 0) { - for (i = 0; i < -k && i < d; i++) - b[j++] = '0'; - for (m = d - i, i = 0; i < m; i++) - b[j++] = i < n ? buff[i] : '0'; - } else if (n > 0) { - for (i = 0; i < -k; i++) - b[j++] = '0'; - for (i = 0; i < n; i++) - b[j++] = buff[i]; - } - } - b[j] = '\0'; - if (w >= 0) { - if (sign < 0 || atsign) - --w; - i = fmt_exponent_length(exp); - if (e >= 0) { - if (i > e) { - if (overflowchar != '\0') - goto OVER; - else - e = i; - } - w -= e + 2; - } else - w -= i + 2; - if (j > w && overflowchar != '\0') - goto OVER; - if (j < w && b[0] == '.') { - *--b = '0'; - j++; - } - for (i = j; i < w; i++) - ecl_write_char(padchar, fmt->stream); - } else { - if (b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } - if (d < 0 && b[0] == '.') { - *--b = '0'; - j++; - } - } - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - writestr_stream(b, fmt->stream); - y = ecl_symbol_value(@'*read-default-float-format*'); - if (exponentchar < 0) { - if (y == @'long-float') { + x = fmt_advance(fmt); + if (ECL_FIXNUMP(x) || + ecl_t_of(x) == t_bignum || + ecl_t_of(x) == t_ratio) + x = ecl_make_single_float(ecl_to_float(x)); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + n = 16; + else + n = 7; + f = ecl_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (d >= 0) { + if (k > 0) { + if (!(k < d + 2)) + fmt_error(fmt, "illegal scale factor"); + m = d + 1; + } else { + if (!(k > -d)) + fmt_error(fmt, "illegal scale factor"); + m = d + k; + } + } else if (w >= 0) { + if (k > 0) + m = w - 1; + else + m = w + k - 1; + if (sign < 0 || atsign) + --m; + if (e >= 0) + m -= e + 2; + else + m -= fmt_exponent_length(e - k + 1) + 2; + } else + m = n; + if (m <= 0) { + if (m == 0 && buff[0] >= '5') { + exp++; + n = m = 1; + buff[0] = '1'; + } else + n = m = 0; + } else if (m < n) { + n = m; + edit_double(n, f, &sign, buff, &exp); + } + while (n >= 0) + if (buff[n - 1] == '0') + --n; + else + break; + exp = exp - k + 1; + j = 0; + if (k > 0) { + for (i = 0; i < k; i++) + b[j++] = i < n ? buff[i] : '0'; + b[j++] = '.'; + if (d >= 0) + for (m = i + (d - k + 1); i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + else + for (; i < n; i++) + b[j++] = buff[i]; + } else { + b[j++] = '.'; + if (d >= 0) { + for (i = 0; i < -k && i < d; i++) + b[j++] = '0'; + for (m = d - i, i = 0; i < m; i++) + b[j++] = i < n ? buff[i] : '0'; + } else if (n > 0) { + for (i = 0; i < -k; i++) + b[j++] = '0'; + for (i = 0; i < n; i++) + b[j++] = buff[i]; + } + } + b[j] = '\0'; + if (w >= 0) { + if (sign < 0 || atsign) + --w; + i = fmt_exponent_length(exp); + if (e >= 0) { + if (i > e) { + if (overflowchar != '\0') + goto OVER; + else + e = i; + } + w -= e + 2; + } else + w -= i + 2; + if (j > w && overflowchar != '\0') + goto OVER; + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + ecl_write_char(padchar, fmt->stream); + } else { + if (b[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (d < 0 && b[0] == '.') { + *--b = '0'; + j++; + } + } + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + writestr_stream(b, fmt->stream); + y = ecl_symbol_value(@'*read-default-float-format*'); + if (exponentchar < 0) { + if (y == @'long-float') { #ifdef ECL_LONG_FLOAT - t = t_longfloat; + t = t_longfloat; #else - t = t_doublefloat; + t = t_doublefloat; #endif - } else if (y == @'double-float') { - t = t_doublefloat; - } else if (y == @'single-float') { - t = t_singlefloat; - } else { - t = t_singlefloat; - } - if (ecl_t_of(x) == t) - exponentchar = 'E'; - else if (ecl_t_of(x) == t_singlefloat) - exponentchar = 'F'; + } else if (y == @'double-float') { + t = t_doublefloat; + } else if (y == @'single-float') { + t = t_singlefloat; + } else { + t = t_singlefloat; + } + if (ecl_t_of(x) == t) + exponentchar = 'E'; + else if (ecl_t_of(x) == t_singlefloat) + exponentchar = 'F'; #ifdef ECL_LONG_FLOAT - else if (ecl_t_of(x) == t_longfloat) - exponentchar = 'L'; + else if (ecl_t_of(x) == t_longfloat) + exponentchar = 'L'; #endif - else - exponentchar = 'D'; - } - ecl_write_char(exponentchar, fmt->stream); - if (exp < 0) - ecl_write_char('-', fmt->stream); - else - ecl_write_char('+', fmt->stream); - if (e >= 0) - for (i = e - fmt_exponent_length(exp); i > 0; --i) - ecl_write_char('0', fmt->stream); - fmt_exponent(fmt, exp); - return; + else + exponentchar = 'D'; + } + ecl_write_char(exponentchar, fmt->stream); + if (exp < 0) + ecl_write_char('-', fmt->stream); + else + ecl_write_char('+', fmt->stream); + if (e >= 0) + for (i = e - fmt_exponent_length(exp); i > 0; --i) + ecl_write_char('0', fmt->stream); + fmt_exponent(fmt, exp); + return; OVER: - w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - for (i = 0; i < w; i++) - ecl_write_char(overflowchar, fmt->stream); - return; + w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + for (i = 0; i < w; i++) + ecl_write_char(overflowchar, fmt->stream); + return; } static void fmt_general_float(format_stack fmt, bool colon, bool atsign) { - int w, d, e, k; - ecl_character overflowchar, padchar, exponentchar; - int sign, exp; - char buff[256]; - cl_object x; - int n, ee, ww, q, dd; + int w, d, e, k; + ecl_character overflowchar, padchar, exponentchar; + int sign, exp; + char buff[256]; + cl_object x; + int n, ee, ww, q, dd; - fmt_not_colon(fmt, colon); - ensure_param(fmt, 7); - w = set_param_positive(fmt, 0, "illegal width"); - d = set_param_positive(fmt, 1, "illegal number of digits"); - e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); - k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); - overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); - padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); - exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); + fmt_not_colon(fmt, colon); + ensure_param(fmt, 7); + w = set_param_positive(fmt, 0, "illegal width"); + d = set_param_positive(fmt, 1, "illegal number of digits"); + e = set_param_positive(fmt, 2, "illegal number of digits in exponent"); + k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1))); + overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0'))); + padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' '))); + exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0'))); - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam > 1) fmt->nparam = 1; - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - if (ecl_t_of(x) == t_doublefloat) - q = 16; - else - q = 7; - edit_double(q, ecl_to_double(x), &sign, buff, &exp); - n = exp + 1; - while (q >= 0) - if (buff[q - 1] == '0') - --q; - else - break; - if (e >= 0) - ee = e + 2; - else - ee = 4; - ww = w - ee; - if (d < 0) { - d = n < 7 ? n : 7; - d = q > d ? q : d; - } - dd = d - n; - if (0 <= dd && dd <= d) { - fmt->nparam = 5; - fmt->param[0] = ecl_make_fixnum(ww); - fmt->param[1] = ecl_make_fixnum(dd); - fmt->param[2] = ECL_NIL; - fmt->param[3] = fmt->param[4]; - fmt->param[4] = fmt->param[5]; - fmt_back_up(fmt); - fmt_fix_float(fmt, colon, atsign); - if (w >= 0) - while (ww++ < w) - ecl_write_char(padchar, fmt->stream); - return; - } - fmt->param[1] = ecl_make_fixnum(d); - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam > 1) fmt->nparam = 1; + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + if (ecl_t_of(x) == t_doublefloat) + q = 16; + else + q = 7; + edit_double(q, ecl_to_double(x), &sign, buff, &exp); + n = exp + 1; + while (q >= 0) + if (buff[q - 1] == '0') + --q; + else + break; + if (e >= 0) + ee = e + 2; + else + ee = 4; + ww = w - ee; + if (d < 0) { + d = n < 7 ? n : 7; + d = q > d ? q : d; + } + dd = d - n; + if (0 <= dd && dd <= d) { + fmt->nparam = 5; + fmt->param[0] = ecl_make_fixnum(ww); + fmt->param[1] = ecl_make_fixnum(dd); + fmt->param[2] = ECL_NIL; + fmt->param[3] = fmt->param[4]; + fmt->param[4] = fmt->param[5]; + fmt_back_up(fmt); + fmt_fix_float(fmt, colon, atsign); + if (w >= 0) + while (ww++ < w) + ecl_write_char(padchar, fmt->stream); + return; + } + fmt->param[1] = ecl_make_fixnum(d); + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); } static void fmt_dollars_float(format_stack fmt, bool colon, bool atsign) { - int d, n, w; - ecl_character padchar; - double f; - int sign; - char buff[256]; - int exp; - int q, i; - cl_object x; + int d, n, w; + ecl_character padchar; + double f; + int sign; + char buff[256]; + int exp; + int q, i; + cl_object x; - ensure_param(fmt, 4); - d = set_param_positive(fmt, 0, "illegal number of digits"); - if (d < 0) d = 2; - n = set_param_positive(fmt, 1, "illegal number of digits"); - if (n < 0) n = 1; - w = set_param_positive(fmt, 2, "illegal width"); - if (w < 0) w = 0; - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - x = fmt_advance(fmt); - if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { - if (fmt->nparam < 3) - fmt->nparam = 0; - else { - fmt->nparam = 1; - fmt->param[0] = fmt->param[2]; - } - fmt_back_up(fmt); - fmt_decimal(fmt, colon, atsign); - return; - } - q = 7; - if (ecl_t_of(x) == t_doublefloat) - q = 16; - f = ecl_to_double(x); - edit_double(q, f, &sign, buff, &exp); - if ((q = exp + d + 1) > 0) - edit_double(q, f, &sign, buff, &exp); - exp++; - if (w > 100 || exp > 100 || exp < -100) { - fmt->nparam = 6; - fmt->param[0] = fmt->param[2]; - fmt->param[1] = ecl_make_fixnum(d + n - 1); - fmt->param[5] = fmt->param[3]; - fmt->param[2] = - fmt->param[3] = - fmt->param[4] = ECL_NIL; - fmt_back_up(fmt); - fmt_exponential_float(fmt, colon, atsign); - } - if (exp > n) - n = exp; - if (sign < 0 || atsign) - --w; - if (colon) { - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - } else { - while (--w > n + d) - ecl_write_char(padchar, fmt->stream); - if (sign < 0) - ecl_write_char('-', fmt->stream); - else if (atsign) - ecl_write_char('+', fmt->stream); - } - for (i = n - exp; i > 0; --i) - ecl_write_char('0', fmt->stream); - for (i = 0; i < exp; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); - ecl_write_char('.', fmt->stream); - for (d += i; i < d; i++) - ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + ensure_param(fmt, 4); + d = set_param_positive(fmt, 0, "illegal number of digits"); + if (d < 0) d = 2; + n = set_param_positive(fmt, 1, "illegal number of digits"); + if (n < 0) n = 1; + w = set_param_positive(fmt, 2, "illegal width"); + if (w < 0) w = 0; + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + x = fmt_advance(fmt); + if (!ECL_REAL_TYPE_P(ecl_t_of(x))) { + if (fmt->nparam < 3) + fmt->nparam = 0; + else { + fmt->nparam = 1; + fmt->param[0] = fmt->param[2]; + } + fmt_back_up(fmt); + fmt_decimal(fmt, colon, atsign); + return; + } + q = 7; + if (ecl_t_of(x) == t_doublefloat) + q = 16; + f = ecl_to_double(x); + edit_double(q, f, &sign, buff, &exp); + if ((q = exp + d + 1) > 0) + edit_double(q, f, &sign, buff, &exp); + exp++; + if (w > 100 || exp > 100 || exp < -100) { + fmt->nparam = 6; + fmt->param[0] = fmt->param[2]; + fmt->param[1] = ecl_make_fixnum(d + n - 1); + fmt->param[5] = fmt->param[3]; + fmt->param[2] = + fmt->param[3] = + fmt->param[4] = ECL_NIL; + fmt_back_up(fmt); + fmt_exponential_float(fmt, colon, atsign); + } + if (exp > n) + n = exp; + if (sign < 0 || atsign) + --w; + if (colon) { + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + } else { + while (--w > n + d) + ecl_write_char(padchar, fmt->stream); + if (sign < 0) + ecl_write_char('-', fmt->stream); + else if (atsign) + ecl_write_char('+', fmt->stream); + } + for (i = n - exp; i > 0; --i) + ecl_write_char('0', fmt->stream); + for (i = 0; i < exp; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); + ecl_write_char('.', fmt->stream); + for (d += i; i < d; i++) + ecl_write_char((i < q ? buff[i] : '0'), fmt->stream); } static void fmt_percent(format_stack fmt, bool colon, bool atsign) { - int n, i; + int n, i; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) { - ecl_write_char('\n', fmt->stream); - if (n == 0) - for (i = fmt->indents; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) { + ecl_write_char('\n', fmt->stream); + if (n == 0) + for (i = fmt->indents; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_ampersand(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - if (n == 0) - return; - if (ecl_file_column(fmt->stream) != 0) - ecl_write_char('\n', fmt->stream); - while (--n > 0) - ecl_write_char('\n', fmt->stream); - fmt->indents = 0; + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + if (n == 0) + return; + if (ecl_file_column(fmt->stream) != 0) + ecl_write_char('\n', fmt->stream); + while (--n > 0) + ecl_write_char('\n', fmt->stream); + fmt->indents = 0; } static void fmt_bar(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('\f', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('\f', fmt->stream); } static void fmt_tilde(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_not_colon(fmt, colon); - fmt_not_atsign(fmt, atsign); - while (n-- > 0) - ecl_write_char('~', fmt->stream); + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_not_colon(fmt, colon); + fmt_not_atsign(fmt, atsign); + while (n-- > 0) + ecl_write_char('~', fmt->stream); } static void fmt_newline(format_stack fmt, bool colon, bool atsign) { - ensure_param(fmt, 0); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) - ecl_write_char('\n', fmt->stream); - while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { - if (colon) - ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); - fmt->ctl_index++; - } + ensure_param(fmt, 0); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) + ecl_write_char('\n', fmt->stream); + while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) { + if (colon) + ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream); + fmt->ctl_index++; + } } static void fmt_tabulate(format_stack fmt, bool colon, bool atsign) { - int colnum, colinc; - int c, i; + int colnum, colinc; + int c, i; - ensure_param(fmt, 2); - fmt_not_colon(fmt, colon); - colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - if (!atsign) { - c = ecl_file_column(fmt->stream); - if (c < 0) { - writestr_stream(" ", fmt->stream); - return; - } - if (c > colnum && colinc <= 0) - return; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } else { - for (i = colnum; i > 0; --i) - ecl_write_char(' ', fmt->stream); - c = ecl_file_column(fmt->stream); - if (c < 0 || colinc <= 0) - return; - colnum = 0; - while (c > colnum) - colnum += colinc; - for (i = colnum - c; i > 0; --i) - ecl_write_char(' ', fmt->stream); - } + ensure_param(fmt, 2); + fmt_not_colon(fmt, colon); + colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + if (!atsign) { + c = ecl_file_column(fmt->stream); + if (c < 0) { + writestr_stream(" ", fmt->stream); + return; + } + if (c > colnum && colinc <= 0) + return; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } else { + for (i = colnum; i > 0; --i) + ecl_write_char(' ', fmt->stream); + c = ecl_file_column(fmt->stream); + if (c < 0 || colinc <= 0) + return; + colnum = 0; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + ecl_write_char(' ', fmt->stream); + } } static void fmt_asterisk(format_stack fmt, bool colon, bool atsign) { - int n; + int n; - ensure_param(fmt, 1); - fmt_not_colon_atsign(fmt, colon, atsign); - if (atsign) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt_go(fmt, n); - } else if (colon) { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - fmt_go(fmt, fmt_index(fmt) - n); - } else { - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); - while (n-- > 0) - fmt_advance(fmt); - } + ensure_param(fmt, 1); + fmt_not_colon_atsign(fmt, colon, atsign); + if (atsign) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt_go(fmt, n); + } else if (colon) { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + fmt_go(fmt, fmt_index(fmt) - n); + } else { + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1))); + while (n-- > 0) + fmt_advance(fmt); + } } static void fmt_indirection(format_stack fmt, bool colon, bool atsign) { - cl_object s, l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; + cl_object s, l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; - ensure_param(fmt, 0); - fmt_not_colon(fmt, colon); - s = fmt_advance(fmt); - if (ecl_t_of(s) != t_base_string) - fmt_error(fmt, "control string expected"); - if (atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy1(fmt, &fmt_old); - } else { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - fmt->ctl_str = s; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - } else - format(fmt, 0, s->base_string.fillp); - fmt_copy(fmt, &fmt_old); - } + ensure_param(fmt, 0); + fmt_not_colon(fmt, colon); + s = fmt_advance(fmt); + if (ecl_t_of(s) != t_base_string) + fmt_error(fmt, "control string expected"); + if (atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy1(fmt, &fmt_old); + } else { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + fmt->ctl_str = s; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + } else + format(fmt, 0, s->base_string.fillp); + fmt_copy(fmt, &fmt_old); + } } static void fmt_case(format_stack fmt, bool colon, bool atsign) { - cl_object x; - cl_index i; - int j; - ecl_character c; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; - bool b; + cl_object x; + cl_index i; + int j; + ecl_character c; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + bool b; - x = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~) expected"); - fmt_copy(&fmt_old, fmt); - fmt->stream = x; - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) - ; - else - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - x = STRING_OUTPUT_STRING(x); - if (!colon && !atsign) - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_upper_case_p(c = ecl_char(x, i))) - c = ecl_char_downcase(c); - ecl_write_char(c, fmt->stream); - } - else if (colon && !atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } else if (ecl_digitp(c,10) == -1) - b = TRUE; - ecl_write_char(c, fmt->stream); - } - else if (!colon && atsign) - for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) { - if (b) - c = ecl_char_upcase(c); - b = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!b) - c = ecl_char_downcase(c); - b = FALSE; - } - ecl_write_char(c, fmt->stream); - } - else - for (i = 0; i < x->base_string.fillp; i++) { - if (ecl_lower_case_p(c = ecl_char(x, i))) - c = ecl_char_upcase(c); - ecl_write_char(c, fmt->stream); - } - if (up_colon) - ecl_longjmp(*fmt->jmp_buf, up_colon); + x = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~) expected"); + fmt_copy(&fmt_old, fmt); + fmt->stream = x; + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) + ; + else + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + x = STRING_OUTPUT_STRING(x); + if (!colon && !atsign) + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_upper_case_p(c = ecl_char(x, i))) + c = ecl_char_downcase(c); + ecl_write_char(c, fmt->stream); + } + else if (colon && !atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } else if (ecl_digitp(c,10) == -1) + b = TRUE; + ecl_write_char(c, fmt->stream); + } + else if (!colon && atsign) + for (b = TRUE, i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) { + if (b) + c = ecl_char_upcase(c); + b = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!b) + c = ecl_char_downcase(c); + b = FALSE; + } + ecl_write_char(c, fmt->stream); + } + else + for (i = 0; i < x->base_string.fillp; i++) { + if (ecl_lower_case_p(c = ecl_char(x, i))) + c = ecl_char_upcase(c); + ecl_write_char(c, fmt->stream); + } + if (up_colon) + ecl_longjmp(*fmt->jmp_buf, up_colon); } static void fmt_conditional(format_stack fmt, bool colon, bool atsign) { - int i, j, k; - cl_object x; - int n; - bool done; - struct format_stack_struct fmt_old; + int i, j, k; + cl_object x; + int n; + bool done; + struct format_stack_struct fmt_old; - fmt_not_colon_atsign(fmt, colon, atsign); - if (colon) { - ensure_param(fmt, 0); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~; expected"); - k = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } else { - fmt_copy(&fmt_old, fmt); - format(fmt, j + 2, k); - fmt_copy1(fmt, &fmt_old); - } - } else if (atsign) { - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (Null(fmt_advance(fmt))) - ; - else { - fmt_back_up(fmt); - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } else { - ensure_param(fmt, 1); - if (fmt->nparam == 0) { - x = fmt_advance(fmt); - if (!ECL_FIXNUMP(x)) - fmt_error(fmt, "illegal argument for conditional"); - n = ecl_fixnum(x); - } else - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - i = fmt->ctl_index; - for (done = FALSE;; --n) { - j = fmt_skip(fmt); - for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) - ; - if (n == 0) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, k); - fmt_copy1(fmt, &fmt_old); - done = TRUE; - } - i = j; - if (ecl_char(fmt->ctl_str, --j) == ']') { - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - return; - } - if (ecl_char(fmt->ctl_str, j) == ';') { - if (ecl_char(fmt->ctl_str, --j) == '~') - continue; - if (ecl_char(fmt->ctl_str, j) == ':') - goto ELSE; - } - fmt_error(fmt, "~~; or ~~] expected"); - } - ELSE: - if (ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~:; expected"); - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') - fmt_error(fmt, "~~] expected"); - if (!done) { - fmt_copy(&fmt_old, fmt); - format(fmt, i, j); - fmt_copy1(fmt, &fmt_old); - } - } + fmt_not_colon_atsign(fmt, colon, atsign); + if (colon) { + ensure_param(fmt, 0); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~; expected"); + k = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } else { + fmt_copy(&fmt_old, fmt); + format(fmt, j + 2, k); + fmt_copy1(fmt, &fmt_old); + } + } else if (atsign) { + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (Null(fmt_advance(fmt))) + ; + else { + fmt_back_up(fmt); + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } else { + ensure_param(fmt, 1); + if (fmt->nparam == 0) { + x = fmt_advance(fmt); + if (!ECL_FIXNUMP(x)) + fmt_error(fmt, "illegal argument for conditional"); + n = ecl_fixnum(x); + } else + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + i = fmt->ctl_index; + for (done = FALSE;; --n) { + j = fmt_skip(fmt); + for (k = j; ecl_char(fmt->ctl_str, --k) != '~';) + ; + if (n == 0) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, k); + fmt_copy1(fmt, &fmt_old); + done = TRUE; + } + i = j; + if (ecl_char(fmt->ctl_str, --j) == ']') { + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + return; + } + if (ecl_char(fmt->ctl_str, j) == ';') { + if (ecl_char(fmt->ctl_str, --j) == '~') + continue; + if (ecl_char(fmt->ctl_str, j) == ':') + goto ELSE; + } + fmt_error(fmt, "~~; or ~~] expected"); + } + ELSE: + if (ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~:; expected"); + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~') + fmt_error(fmt, "~~] expected"); + if (!done) { + fmt_copy(&fmt_old, fmt); + format(fmt, i, j); + fmt_copy1(fmt, &fmt_old); + } + } } static void fmt_iteration(format_stack fmt, bool colon, bool atsign) { - int n, i; - volatile int j; - bool colon_close = FALSE; - cl_object l; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - int up_colon; + int n, i; + volatile int j; + bool colon_close = FALSE; + cl_object l; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; - ensure_param(fmt, 1); - n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); - i = fmt->ctl_index; - j = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j) != '}') - fmt_error(fmt, "~~} expected"); - if (ecl_char(fmt->ctl_str, --j) == ':') { - colon_close = TRUE; - --j; - } - if (ecl_char(fmt->ctl_str, j) != '~') - fmt_error(fmt, "syntax error"); - if (!colon && !atsign) { - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L1; - while (fmt_more_args_p(fmt)) { - L1: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (colon && !atsign) { - int fl = 0; - volatile cl_object l0; - l0 = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - for (l = l0; !ecl_endp(l); l = CDR(l)) - fl += ecl_length(CAR(l)); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L2; - while (!ecl_endp(l0)) { - L2: - if (n-- <= 0) - break; - l = CAR(l0); - l0 = CDR(l0); - fmt_set_arg_list(fmt, l); - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - } - fmt_copy(fmt, &fmt_old); - } else if (!colon && atsign) { - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if (colon_close) - goto L3; - while (fmt_more_args_p(fmt)) { - L3: - if (n-- <= 0) - break; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - break; - } - format(fmt, i, j); - } - fmt_copy1(fmt, &fmt_old); - } else if (colon && atsign) { - if (colon_close) - goto L4; - while (fmt_more_args_p(fmt)) { - L4: - if (n-- <= 0) - break; - l = fmt_advance(fmt); - fmt_copy(&fmt_old, fmt); - fmt_set_arg_list(fmt, l); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - fmt_copy(fmt, &fmt_old); - if (--up_colon) - break; - else - continue; - } - format(fmt, i, j); - fmt_copy(fmt, &fmt_old); - } - } + ensure_param(fmt, 1); + n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000))); + i = fmt->ctl_index; + j = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j) != '}') + fmt_error(fmt, "~~} expected"); + if (ecl_char(fmt->ctl_str, --j) == ':') { + colon_close = TRUE; + --j; + } + if (ecl_char(fmt->ctl_str, j) != '~') + fmt_error(fmt, "syntax error"); + if (!colon && !atsign) { + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L1; + while (fmt_more_args_p(fmt)) { + L1: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (colon && !atsign) { + int fl = 0; + volatile cl_object l0; + l0 = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + for (l = l0; !ecl_endp(l); l = CDR(l)) + fl += ecl_length(CAR(l)); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L2; + while (!ecl_endp(l0)) { + L2: + if (n-- <= 0) + break; + l = CAR(l0); + l0 = CDR(l0); + fmt_set_arg_list(fmt, l); + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + } + fmt_copy(fmt, &fmt_old); + } else if (!colon && atsign) { + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if (colon_close) + goto L3; + while (fmt_more_args_p(fmt)) { + L3: + if (n-- <= 0) + break; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + break; + } + format(fmt, i, j); + } + fmt_copy1(fmt, &fmt_old); + } else if (colon && atsign) { + if (colon_close) + goto L4; + while (fmt_more_args_p(fmt)) { + L4: + if (n-- <= 0) + break; + l = fmt_advance(fmt); + fmt_copy(&fmt_old, fmt); + fmt_set_arg_list(fmt, l); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + fmt_copy(fmt, &fmt_old); + if (--up_colon) + break; + else + continue; + } + format(fmt, i, j); + fmt_copy(fmt, &fmt_old); + } + } } static void fmt_justification(format_stack fmt, volatile bool colon, bool atsign) { - int mincol, colinc; - ecl_character minpad, padchar; - volatile cl_object fields; - cl_object p; - struct format_stack_struct fmt_old; - jmp_buf fmt_jmp_buf0; - volatile int i, j, k, l, m, j0, l0; - int up_colon; - volatile cl_object special = ECL_NIL; - volatile int spare_spaces, line_length; + int mincol, colinc; + ecl_character minpad, padchar; + volatile cl_object fields; + cl_object p; + struct format_stack_struct fmt_old; + jmp_buf fmt_jmp_buf0; + volatile int i, j, k, l, m, j0, l0; + int up_colon; + volatile cl_object special = ECL_NIL; + volatile int spare_spaces, line_length; - ensure_param(fmt, 4); - mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); - minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); + ensure_param(fmt, 4); + mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1))); + minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' '))); - fields = ECL_NIL; - for (;;) { - cl_object this_field = ecl_make_string_output_stream(64, 1); - i = fmt->ctl_index; - j0 = j = fmt_skip(fmt); - while (ecl_char(fmt->ctl_str, --j) != '~') - ; + fields = ECL_NIL; + for (;;) { + cl_object this_field = ecl_make_string_output_stream(64, 1); + i = fmt->ctl_index; + j0 = j = fmt_skip(fmt); + while (ecl_char(fmt->ctl_str, --j) != '~') + ; - fmt_copy(&fmt_old, fmt); - fmt->jmp_buf = &fmt_jmp_buf0; - if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { - if (--up_colon) - fmt_error(fmt, "illegal ~~:^"); - fmt_copy1(fmt, &fmt_old); - while (ecl_char(fmt->ctl_str, --j0) != '>') - j0 = fmt_skip(fmt); - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } - fmt->stream = this_field; - format(fmt, i, j); - fields = CONS(STRING_OUTPUT_STRING(this_field), fields); - fmt_copy1(fmt, &fmt_old); + fmt_copy(&fmt_old, fmt); + fmt->jmp_buf = &fmt_jmp_buf0; + if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) { + if (--up_colon) + fmt_error(fmt, "illegal ~~:^"); + fmt_copy1(fmt, &fmt_old); + while (ecl_char(fmt->ctl_str, --j0) != '>') + j0 = fmt_skip(fmt); + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } + fmt->stream = this_field; + format(fmt, i, j); + fields = CONS(STRING_OUTPUT_STRING(this_field), fields); + fmt_copy1(fmt, &fmt_old); - if (ecl_char(fmt->ctl_str, --j0) == '>') { - if (ecl_char(fmt->ctl_str, --j0) != '~') - fmt_error(fmt, "~~> expected"); - break; - } else if (ecl_char(fmt->ctl_str, j0) != ';') - fmt_error(fmt, "~~; expected"); - else if (ecl_char(fmt->ctl_str, --j0) == ':') { - if (ecl_length(fields) != 1 || !Null(special)) - fmt_error(fmt, "illegal ~~:;"); - special = CAR(fields); - fields = CDR(fields); - for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) - ; - fmt_copy(&fmt_old, fmt); - format(fmt, j, j0 + 2); - fmt_copy1(fmt, &fmt_old); - spare_spaces = fmt->spare_spaces; - line_length = fmt->line_length; - } else if (ecl_char(fmt->ctl_str, j0) != '~') - fmt_error(fmt, "~~; expected"); - } - /* - * Compute the length of items to be output. If the clause ~:; was - * found, the first item is not included. - */ - fields = cl_nreverse(fields); - for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) - l += CAR(p)->base_string.fillp; - /* - * Count the number of segments that need padding, "M". If the colon - * modifier, the first item needs padding. If the @@ modifier is - * present, the last modifier also needs padding. - */ - m = ecl_length(fields) - 1; - if (m <= 0 && !colon && !atsign) { - m = 0; - colon = TRUE; - } - if (colon) - m++; - if (atsign) - m++; - /* - * Count the minimal length in which the text fits. This length must - * the smallest integer of the form l = mincol + k * colinc. If the - * length exceeds the line length, the text before the ~:; is output - * first. - */ - l0 = l; - l += minpad * m; - for (k = 0; mincol + k * colinc < l; k++) - ; - l = mincol + k * colinc; - if (special != ECL_NIL && - ecl_file_column(fmt->stream) + l + spare_spaces > line_length) - ecl_princ(special, fmt->stream); - /* - * Output the text with the padding segments. The total number of - * padchars is kept in "l", and it is shared equally among all segments. - */ - l -= l0; - for (p = fields; p != ECL_NIL; p = CDR(p)) { - if (p != fields || colon) - for (j = l / m, l -= j, --m; j > 0; --j) - ecl_write_char(padchar, fmt->stream); - ecl_princ(CAR(p), fmt->stream); - } - if (atsign) - for (j = l; j > 0; --j) - ecl_write_char(padchar, fmt->stream); + if (ecl_char(fmt->ctl_str, --j0) == '>') { + if (ecl_char(fmt->ctl_str, --j0) != '~') + fmt_error(fmt, "~~> expected"); + break; + } else if (ecl_char(fmt->ctl_str, j0) != ';') + fmt_error(fmt, "~~; expected"); + else if (ecl_char(fmt->ctl_str, --j0) == ':') { + if (ecl_length(fields) != 1 || !Null(special)) + fmt_error(fmt, "illegal ~~:;"); + special = CAR(fields); + fields = CDR(fields); + for (j = j0; ecl_char(fmt->ctl_str, j) != '~'; --j) + ; + fmt_copy(&fmt_old, fmt); + format(fmt, j, j0 + 2); + fmt_copy1(fmt, &fmt_old); + spare_spaces = fmt->spare_spaces; + line_length = fmt->line_length; + } else if (ecl_char(fmt->ctl_str, j0) != '~') + fmt_error(fmt, "~~; expected"); + } + /* + * Compute the length of items to be output. If the clause ~:; was + * found, the first item is not included. + */ + fields = cl_nreverse(fields); + for (p = fields, l = 0; p != ECL_NIL; p = CDR(p)) + l += CAR(p)->base_string.fillp; + /* + * Count the number of segments that need padding, "M". If the colon + * modifier, the first item needs padding. If the @@ modifier is + * present, the last modifier also needs padding. + */ + m = ecl_length(fields) - 1; + if (m <= 0 && !colon && !atsign) { + m = 0; + colon = TRUE; + } + if (colon) + m++; + if (atsign) + m++; + /* + * Count the minimal length in which the text fits. This length must + * the smallest integer of the form l = mincol + k * colinc. If the + * length exceeds the line length, the text before the ~:; is output + * first. + */ + l0 = l; + l += minpad * m; + for (k = 0; mincol + k * colinc < l; k++) + ; + l = mincol + k * colinc; + if (special != ECL_NIL && + ecl_file_column(fmt->stream) + l + spare_spaces > line_length) + ecl_princ(special, fmt->stream); + /* + * Output the text with the padding segments. The total number of + * padchars is kept in "l", and it is shared equally among all segments. + */ + l -= l0; + for (p = fields; p != ECL_NIL; p = CDR(p)) { + if (p != fields || colon) + for (j = l / m, l -= j, --m; j > 0; --j) + ecl_write_char(padchar, fmt->stream); + ecl_princ(CAR(p), fmt->stream); + } + if (atsign) + for (j = l; j > 0; --j) + ecl_write_char(padchar, fmt->stream); } static void fmt_up_and_out(format_stack fmt, bool colon, bool atsign) { - int i, j, k; + int i, j, k; - ensure_param(fmt, 3); - fmt_not_atsign(fmt, atsign); - if (fmt->nparam == 0) { - if (!fmt_more_args_p(fmt)) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 1) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - if (i == 0) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else if (fmt->nparam == 2) { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - if (i == j) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } else { - i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); - k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); - if (i <= j && j <= k) - ecl_longjmp(*fmt->jmp_buf, ++colon); - } + ensure_param(fmt, 3); + fmt_not_atsign(fmt, atsign); + if (fmt->nparam == 0) { + if (!fmt_more_args_p(fmt)) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 1) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + if (i == 0) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else if (fmt->nparam == 2) { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + if (i == j) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } else { + i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0))); + k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0))); + if (i <= j && j <= k) + ecl_longjmp(*fmt->jmp_buf, ++colon); + } } static void fmt_semicolon(format_stack fmt, bool colon, bool atsign) { - fmt_not_atsign(fmt, atsign); - if (!colon) - fmt_error(fmt, "~~:; expected"); - ensure_param(fmt, 2); - fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); - fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); + fmt_not_atsign(fmt, atsign); + if (!colon) + fmt_error(fmt, "~~:; expected"); + ensure_param(fmt, 2); + fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0))); + fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72))); } @(defun si::formatter-aux (strm string &rest args) @ - @(return doformat(narg, strm, string, args, TRUE)) + @(return doformat(narg, strm, string, args, TRUE)) @) static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va_list args, bool in_formatter) { - struct format_stack_struct fmt; - jmp_buf fmt_jmp_buf0; - int colon; - cl_object output = cl_grab_rest_args(args); - while(!ecl_stringp(string)) + struct format_stack_struct fmt; + jmp_buf fmt_jmp_buf0; + int colon; + cl_object output = cl_grab_rest_args(args); + while(!ecl_stringp(string)) #ifdef ECL_UNICODE - string = ecl_type_error(@'format', "argument", string, @'string'); + string = ecl_type_error(@'format', "argument", string, @'string'); #else - string = ecl_type_error(@'format', "argument", string, @'base-string'); + string = ecl_type_error(@'format', "argument", string, @'base-string'); #endif - fmt.stream = strm; - fmt_set_arg_list(&fmt, output); - fmt.jmp_buf = &fmt_jmp_buf0; - if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) - fmt.indents = ecl_file_column(strm); - else - fmt.indents = 0; - fmt.ctl_str = string; - fmt.aux_stream = get_aux_stream(); - fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); - if ((colon = ecl_setjmp(*fmt.jmp_buf))) { - if (--colon) - fmt_error(&fmt, "illegal ~~:^"); - } else { - format(&fmt, 0, string->base_string.fillp); - ecl_force_output(strm); - } - ecl_process_env()->fmt_aux_stream = fmt.aux_stream; - if (!in_formatter) - output = ECL_NIL; - return output; + fmt.stream = strm; + fmt_set_arg_list(&fmt, output); + fmt.jmp_buf = &fmt_jmp_buf0; + if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL) + fmt.indents = ecl_file_column(strm); + else + fmt.indents = 0; + fmt.ctl_str = string; + fmt.aux_stream = get_aux_stream(); + fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); + if ((colon = ecl_setjmp(*fmt.jmp_buf))) { + if (--colon) + fmt_error(&fmt, "illegal ~~:^"); + } else { + format(&fmt, 0, string->base_string.fillp); + ecl_force_output(strm); + } + ecl_process_env()->fmt_aux_stream = fmt.aux_stream; + if (!in_formatter) + output = ECL_NIL; + return output; } static void format(format_stack fmt, cl_index start, cl_index end) { - ecl_character c; - cl_index i, n; - bool colon, atsign; - cl_object x; + ecl_character c; + cl_index i, n; + bool colon, atsign; + cl_object x; - fmt->ctl_index = start; - fmt->ctl_end = end; + fmt->ctl_index = start; + fmt->ctl_end = end; LOOP: - if (fmt->ctl_index >= fmt->ctl_end) - return; - if ((c = ctl_advance(fmt)) != '~') { - ecl_write_char(c, fmt->stream); - goto LOOP; - } - n = 0; - for (;;) { - switch (c = ctl_advance(fmt)) { - case ',': - fmt->param[n] = ECL_NIL; - break; + if (fmt->ctl_index >= fmt->ctl_end) + return; + if ((c = ctl_advance(fmt)) != '~') { + ecl_write_char(c, fmt->stream); + goto LOOP; + } + n = 0; + for (;;) { + switch (c = ctl_advance(fmt)) { + case ',': + fmt->param[n] = ECL_NIL; + break; - case '+': case '-': - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - i = fmt->ctl_index - 1; - do { - c = ctl_advance(fmt); - } while (ecl_digitp(c,10) != -1); - x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); - INTEGER: - /* FIXME! A hack to solve the problem of bignums in arguments */ - if (x == OBJNULL || !ecl_numberp(x)) - fmt_error(fmt, "integer expected"); - if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); - } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { - fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); - } else { - fmt->param[n] = x; - } - if (ECL_FIXNUMP(x)) { - fmt->param[n] = x; - } else if (ecl_plusp(x)) { - fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - } else { - fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); - } - break; + case '+': case '-': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = fmt->ctl_index - 1; + do { + c = ctl_advance(fmt); + } while (ecl_digitp(c,10) != -1); + x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10); + INTEGER: + /* FIXME! A hack to solve the problem of bignums in arguments */ + if (x == OBJNULL || !ecl_numberp(x)) + fmt_error(fmt, "integer expected"); + if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT); + } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) { + fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT); + } else { + fmt->param[n] = x; + } + if (ECL_FIXNUMP(x)) { + fmt->param[n] = x; + } else if (ecl_plusp(x)) { + fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + } else { + fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM); + } + break; - case '\'': - fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); - c = ctl_advance(fmt); - break; + case '\'': + fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt)); + c = ctl_advance(fmt); + break; - case 'v': case 'V': - x = fmt_advance(fmt); - c = ctl_advance(fmt); - if (ecl_t_of(x) == t_character) { - fmt->param[n] = x; - } else { - goto INTEGER; - } - break; + case 'v': case 'V': + x = fmt_advance(fmt); + c = ctl_advance(fmt); + if (ecl_t_of(x) == t_character) { + fmt->param[n] = x; + } else { + goto INTEGER; + } + break; - case '#': - fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); - c = ctl_advance(fmt); - break; + case '#': + fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt)); + c = ctl_advance(fmt); + break; - default: - if (n > 0) - fmt_error(fmt, "illegal ,"); - else - goto DIRECTIVE; - } - n++; - if (n == FMT_MAX_PARAM) - fmt_error(fmt, "too many parameters"); - if (c != ',') - break; - } + default: + if (n > 0) + fmt_error(fmt, "illegal ,"); + else + goto DIRECTIVE; + } + n++; + if (n == FMT_MAX_PARAM) + fmt_error(fmt, "too many parameters"); + if (c != ',') + break; + } DIRECTIVE: - colon = atsign = FALSE; - if (c == ':') { - colon = TRUE; - c = ctl_advance(fmt); - } - if (c == '@@') { - atsign = TRUE; - c = ctl_advance(fmt); - } - fmt->nparam = n; - switch (c) { - case 'a': case 'A': - fmt_ascii(fmt, colon, atsign); - break; + colon = atsign = FALSE; + if (c == ':') { + colon = TRUE; + c = ctl_advance(fmt); + } + if (c == '@@') { + atsign = TRUE; + c = ctl_advance(fmt); + } + fmt->nparam = n; + switch (c) { + case 'a': case 'A': + fmt_ascii(fmt, colon, atsign); + break; - case 's': case 'S': - fmt_S_expression(fmt, colon, atsign); - break; + case 's': case 'S': + fmt_S_expression(fmt, colon, atsign); + break; - case 'd': case 'D': - fmt_decimal(fmt, colon, atsign); - break; + case 'd': case 'D': + fmt_decimal(fmt, colon, atsign); + break; - case 'b': case 'B': - fmt_binary(fmt, colon, atsign); - break; + case 'b': case 'B': + fmt_binary(fmt, colon, atsign); + break; - case 'o': case 'O': - fmt_octal(fmt, colon, atsign); - break; + case 'o': case 'O': + fmt_octal(fmt, colon, atsign); + break; - case 'x': case 'X': - fmt_hexadecimal(fmt, colon, atsign); - break; + case 'x': case 'X': + fmt_hexadecimal(fmt, colon, atsign); + break; - case 'r': case 'R': - fmt_radix(fmt, colon, atsign); - break; + case 'r': case 'R': + fmt_radix(fmt, colon, atsign); + break; - case 'p': case 'P': - fmt_plural(fmt, colon, atsign); - break; + case 'p': case 'P': + fmt_plural(fmt, colon, atsign); + break; - case 'c': case 'C': - fmt_character(fmt, colon, atsign); - break; + case 'c': case 'C': + fmt_character(fmt, colon, atsign); + break; - case 'f': case 'F': - fmt_fix_float(fmt, colon, atsign); - break; + case 'f': case 'F': + fmt_fix_float(fmt, colon, atsign); + break; - case 'e': case 'E': - fmt_exponential_float(fmt, colon, atsign); - break; + case 'e': case 'E': + fmt_exponential_float(fmt, colon, atsign); + break; - case 'g': case 'G': - fmt_general_float(fmt, colon, atsign); - break; + case 'g': case 'G': + fmt_general_float(fmt, colon, atsign); + break; - case '$': - fmt_dollars_float(fmt, colon, atsign); - break; + case '$': + fmt_dollars_float(fmt, colon, atsign); + break; - case '%': - fmt_percent(fmt, colon, atsign); - break; + case '%': + fmt_percent(fmt, colon, atsign); + break; - case '&': - fmt_ampersand(fmt, colon, atsign); - break; + case '&': + fmt_ampersand(fmt, colon, atsign); + break; - case '|': - fmt_bar(fmt, colon, atsign); - break; + case '|': + fmt_bar(fmt, colon, atsign); + break; - case '~': - fmt_tilde(fmt, colon, atsign); - break; + case '~': + fmt_tilde(fmt, colon, atsign); + break; - case '\n': - case '\r': - fmt_newline(fmt, colon, atsign); - break; + case '\n': + case '\r': + fmt_newline(fmt, colon, atsign); + break; - case 't': case 'T': - fmt_tabulate(fmt, colon, atsign); - break; + case 't': case 'T': + fmt_tabulate(fmt, colon, atsign); + break; - case '*': - fmt_asterisk(fmt, colon, atsign); - break; + case '*': + fmt_asterisk(fmt, colon, atsign); + break; - case '?': - fmt_indirection(fmt, colon, atsign); - break; + case '?': + fmt_indirection(fmt, colon, atsign); + break; - case '(': - fmt_case(fmt, colon, atsign); - break; + case '(': + fmt_case(fmt, colon, atsign); + break; - case '[': - fmt_conditional(fmt, colon, atsign); - break; + case '[': + fmt_conditional(fmt, colon, atsign); + break; - case '{': - fmt_iteration(fmt, colon, atsign); - break; + case '{': + fmt_iteration(fmt, colon, atsign); + break; - case '<': - fmt_justification(fmt, colon, atsign); - break; + case '<': + fmt_justification(fmt, colon, atsign); + break; - case '^': - fmt_up_and_out(fmt, colon, atsign); - break; + case '^': + fmt_up_and_out(fmt, colon, atsign); + break; - case ';': - fmt_semicolon(fmt, colon, atsign); - break; + case ';': + fmt_semicolon(fmt, colon, atsign); + break; - default: - fmt_error(fmt, "illegal directive"); - } - goto LOOP; + default: + fmt_error(fmt, "illegal directive"); + } + goto LOOP; } #endif /* !ECL_CMU_FORMAT */ @(defun format (strm string &rest args) - cl_object output = ECL_NIL; - int null_strm = 0; + cl_object output = ECL_NIL; + int null_strm = 0; @ - if (Null(strm)) { + if (Null(strm)) { #ifdef ECL_UNICODE - strm = ecl_alloc_adjustable_extended_string(64); + strm = ecl_alloc_adjustable_extended_string(64); #else - strm = ecl_alloc_adjustable_base_string(64); + strm = ecl_alloc_adjustable_base_string(64); #endif - null_strm = 1; - } else if (strm == ECL_T) { - strm = ecl_symbol_value(@'*standard-output*'); - } - if (ecl_stringp(strm)) { - output = strm; - if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { - cl_error(7, @'si::format-error', - @':format-control', - make_constant_base_string( + null_strm = 1; + } else if (strm == ECL_T) { + strm = ecl_symbol_value(@'*standard-output*'); + } + if (ecl_stringp(strm)) { + output = strm; + if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) { + cl_error(7, @'si::format-error', + @':format-control', + make_constant_base_string( "Cannot output to a non adjustable string."), - @':control-string', string, - @':offset', ecl_make_fixnum(0)); + @':control-string', string, + @':offset', ecl_make_fixnum(0)); } - strm = si_make_string_output_stream_from_string(strm); - if (null_strm == 0) - output = ECL_NIL; - } - if (!Null(cl_functionp(string))) { - cl_apply(3, string, strm, cl_grab_rest_args(args)); - } else { + strm = si_make_string_output_stream_from_string(strm); + if (null_strm == 0) + output = ECL_NIL; + } + if (!Null(cl_functionp(string))) { + cl_apply(3, string, strm, cl_grab_rest_args(args)); + } else { #ifdef ECL_CMU_FORMAT - _ecl_funcall4(@'si::formatter-aux', strm, string, - cl_grab_rest_args(args)); + _ecl_funcall4(@'si::formatter-aux', strm, string, + cl_grab_rest_args(args)); #else - doformat(narg, strm, string, args, FALSE); + doformat(narg, strm, string, args, FALSE); #endif - } - output = cl_copy_seq(output); - @(return output) + } + output = cl_copy_seq(output); + @(return output) @) diff --git a/src/c/gbc-new.d b/src/c/gbc-new.d index 06c80cf1e..243dbcf77 100644 --- a/src/c/gbc-new.d +++ b/src/c/gbc-new.d @@ -22,7 +22,7 @@ /******************************* EXPORTS ******************************/ bool GC_enable; -int gc_time; /* Beppe */ +int gc_time; /* Beppe */ /******************************* ------- ******************************/ @@ -31,38 +31,38 @@ int gc_time; /* Beppe */ Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f. */ -static int *mark_table; +static int *mark_table; static void inline set_mark_bit(void *x) { - int w = (int)x; - int m = (w - DATA_START) >> 7; - int i = (w >> 2) & 0x1f; - mark_table[m] |= (1 << i); + int w = (int)x; + int m = (w - DATA_START) >> 7; + int i = (w >> 2) & 0x1f; + mark_table[m] |= (1 << i); } static int inline get_mark_bit(void *x) { - int w = (int)x; - int m = (w - DATA_START) >> 7; - int i = (w >> 2) & 0x1f; - return (mark_table[m] >> i) & 1; + int w = (int)x; + int m = (w - DATA_START) >> 7; + int i = (w >> 2) & 0x1f; + return (mark_table[m] >> i) & 1; } -#define inheap(pp) ((unsigned long)(pp) < (unsigned long)heap_end) +#define inheap(pp) ((unsigned long)(pp) < (unsigned long)heap_end) #define VALID_DATA_ADDRESS(pp) \ !ECL_IMMEDIATE(pp) && (cl_index)DATA_START <= (cl_index)(pp) && (cl_index)(pp) < (cl_index)heap_end cl_object siVgc_verbose; cl_object siVgc_message; -static bool debug = FALSE; -static int maxpage; +static bool debug = FALSE; +static int maxpage; -#define GC_ROOT_MAX 200 -static cl_object *gc_root[GC_ROOT_MAX]; -static int gc_roots; +#define GC_ROOT_MAX 200 +static cl_object *gc_root[GC_ROOT_MAX]; +static int gc_roots; -static bool collect_blocks; +static bool collect_blocks; /* We must register location, since value may be reassigned (e.g. malloc_list) @@ -75,20 +75,20 @@ extern void sigint (void); void register_root(cl_object *p) { - if (gc_roots >= GC_ROOT_MAX) - error("too many roots"); - gc_root[gc_roots++] = p; + if (gc_roots >= GC_ROOT_MAX) + error("too many roots"); + gc_root[gc_roots++] = p; } @(defun gc (area) @ - if (!GC_enabled()) - error("GC is not enabled"); - if (Null(area)) - gc(t_cons); - else - gc(t_contiguous); - @(return) + if (!GC_enabled()) + error("GC is not enabled"); + if (Null(area)) + gc(t_cons); + else + gc(t_contiguous); + @(return) @) /*---------------------------------------------------------------------- @@ -115,307 +115,307 @@ register_root(cl_object *p) static void _mark_object(cl_object x) { - size_t i, j; - cl_object *p, y; - char *cp; + size_t i, j; + cl_object *p, y; + char *cp; - cs_check(x); + cs_check(x); BEGIN: #if 0 - /* We cannot get here because mark_object() and mark_next() already check this */ - if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ - if (x == OBJNULL) - return; + /* We cannot get here because mark_object() and mark_next() already check this */ + if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ + if (x == OBJNULL) + return; #endif - if (get_mark_bit(x)) - return; - set_mark_bit(x); + if (get_mark_bit(x)) + return; + set_mark_bit(x); - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { - case t_bignum: + case t_bignum: #ifdef WITH_GMP - if (collect_blocks) { - /* GMP may set num.alloc before actually allocating anything. - With these checks we make sure we do not move anything - we don't have to. Besides, we use big_dim as the size - of the object, because big_size might even be smaller. - */ - char *limbs = (char *)x->big.big_limbs; - size_t size = x->big.big_dim * sizeof(mp_limb_t); - if (size) mark_contblock(limbs, size); - } + if (collect_blocks) { + /* GMP may set num.alloc before actually allocating anything. + With these checks we make sure we do not move anything + we don't have to. Besides, we use big_dim as the size + of the object, because big_size might even be smaller. + */ + char *limbs = (char *)x->big.big_limbs; + size_t size = x->big.big_dim * sizeof(mp_limb_t); + if (size) mark_contblock(limbs, size); + } #endif /* WITH_GMP */ - break; + break; - case t_ratio: - mark_object(x->ratio.num); - mark_next(x->ratio.den); - break; + case t_ratio: + mark_object(x->ratio.num); + mark_next(x->ratio.den); + break; #ifdef ECL_SSE2 - case t_sse_pack: + case t_sse_pack: #endif - case t_singlefloat: - case t_doublefloat: - break; + case t_singlefloat: + case t_doublefloat: + break; - case t_complex: - mark_object(x->complex.imag); - mark_next(x->complex.real); - break; + case t_complex: + mark_object(x->complex.imag); + mark_next(x->complex.real); + break; - case t_character: - break; + case t_character: + break; - case t_symbol: - mark_object(x->symbol.name); - mark_object(x->symbol.plist); - mark_object(ECL_SYM_FUN(x)); - mark_next(SYM_VAL(x)); - break; + case t_symbol: + mark_object(x->symbol.name); + mark_object(x->symbol.plist); + mark_object(ECL_SYM_FUN(x)); + mark_next(SYM_VAL(x)); + break; - case t_package: - mark_object(x->pack.name); - mark_object(x->pack.nicknames); - mark_object(x->pack.shadowings); - mark_object(x->pack.uses); - mark_object(x->pack.usedby); - mark_object(x->pack.internal); - mark_next(x->pack.external); - break; + case t_package: + mark_object(x->pack.name); + mark_object(x->pack.nicknames); + mark_object(x->pack.shadowings); + mark_object(x->pack.uses); + mark_object(x->pack.usedby); + mark_object(x->pack.internal); + mark_next(x->pack.external); + break; - case t_cons: - mark_object(CAR(x)); - mark_next(CDR(x)); - break; + case t_cons: + mark_object(CAR(x)); + mark_next(CDR(x)); + break; - case t_hashtable: - mark_object(x->hash.rehash_size); - mark_object(x->hash.threshold); - if (x->hash.data == NULL) - break; - for (i = 0, j = x->hash.size; i < j; i++) { - mark_object(x->hash.data[i].key); - mark_object(x->hash.data[i].value); - } - mark_contblock(x->hash.data, j * sizeof(struct hashtable_entry)); - break; + case t_hashtable: + mark_object(x->hash.rehash_size); + mark_object(x->hash.threshold); + if (x->hash.data == NULL) + break; + for (i = 0, j = x->hash.size; i < j; i++) { + mark_object(x->hash.data[i].key); + mark_object(x->hash.data[i].value); + } + mark_contblock(x->hash.data, j * sizeof(struct hashtable_entry)); + break; - case t_array: - mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); + case t_array: + mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - if ((y = x->array.displaced) != ECL_NIL) - mark_displaced(y); - cp = (char *)x->array.self.t; - if (cp == NULL) - break; - switch ((enum aelttype)x->array.elttype) { + case t_vector: + if ((y = x->array.displaced) != ECL_NIL) + mark_displaced(y); + cp = (char *)x->array.self.t; + if (cp == NULL) + break; + switch ((enum aelttype)x->array.elttype) { #ifdef ECL_UNICODE - case ecl_aet_ch: + case ecl_aet_ch: #endif - case ecl_aet_object: - if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { - cl_object *p = x->array.self.t; - cl_index i; - if (x->array.t == t_vector && x->vector.hasfillp) - i = x->vector.fillp; - else - i = x->vector.dim; - while (i-- > 0) - mark_object(p[i]); - } - j = sizeof(cl_object)*x->array.dim; - break; - case ecl_aet_bc: - j = x->array.dim; - break; - case ecl_aet_bit: - j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - break; - case ecl_aet_fix: - j = x->array.dim * sizeof(cl_fixnum); - break; - case ecl_aet_sf: - j = x->array.dim * sizeof(float); - break; - case ecl_aet_df: - j = x->array.dim * sizeof(double); - break; - default: - error("Allocation botch: unknown array element type"); - } - goto COPY_ARRAY; - case t_base_string: - if ((y = x->base_string.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->base_string.self; - if (cp == NULL) - break; - j = x->base_string.dim; - COPY_ARRAY: - mark_contblock(cp, j); - break; - case t_bitvector: - if ((y = x->vector.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->vector.self.bit; - if (cp == NULL) - break; - j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - goto COPY_ARRAY; + case ecl_aet_object: + if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { + cl_object *p = x->array.self.t; + cl_index i; + if (x->array.t == t_vector && x->vector.hasfillp) + i = x->vector.fillp; + else + i = x->vector.dim; + while (i-- > 0) + mark_object(p[i]); + } + j = sizeof(cl_object)*x->array.dim; + break; + case ecl_aet_bc: + j = x->array.dim; + break; + case ecl_aet_bit: + j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); + break; + case ecl_aet_fix: + j = x->array.dim * sizeof(cl_fixnum); + break; + case ecl_aet_sf: + j = x->array.dim * sizeof(float); + break; + case ecl_aet_df: + j = x->array.dim * sizeof(double); + break; + default: + error("Allocation botch: unknown array element type"); + } + goto COPY_ARRAY; + case t_base_string: + if ((y = x->base_string.displaced) != ECL_NIL) + mark_displaced(y); + cp = x->base_string.self; + if (cp == NULL) + break; + j = x->base_string.dim; + COPY_ARRAY: + mark_contblock(cp, j); + break; + case t_bitvector: + if ((y = x->vector.displaced) != ECL_NIL) + mark_displaced(y); + cp = x->vector.self.bit; + if (cp == NULL) + break; + j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); + goto COPY_ARRAY; #ifndef CLOS - case t_structure: - mark_object(x->str.name); - p = x->str.self; - if (p == NULL) - break; - for (i = 0, j = x->str.length; i < j; i++) - mark_object(p[i]); - mark_contblock(p, j*sizeof(cl_object)); - break; + case t_structure: + mark_object(x->str.name); + p = x->str.self; + if (p == NULL) + break; + for (i = 0, j = x->str.length; i < j; i++) + mark_object(p[i]); + mark_contblock(p, j*sizeof(cl_object)); + break; #endif CLOS - case t_stream: - switch ((enum smmode)x->stream.mode) { - case ecl_smm_closed: - /* Rest of fields are NULL */ - mark_next(x->stream.object1); - break; - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - case ecl_smm_probe: - mark_object(x->stream.object0); - mark_object(x->stream.object1); - mark_contblock(x->stream.buffer, BUFSIZ); - break; + case t_stream: + switch ((enum smmode)x->stream.mode) { + case ecl_smm_closed: + /* Rest of fields are NULL */ + mark_next(x->stream.object1); + break; + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: + case ecl_smm_probe: + mark_object(x->stream.object0); + mark_object(x->stream.object1); + mark_contblock(x->stream.buffer, BUFSIZ); + break; - case ecl_smm_synonym: - mark_next(x->stream.object0); - break; + case ecl_smm_synonym: + mark_next(x->stream.object0); + break; - case ecl_smm_broadcast: - case ecl_smm_concatenated: - mark_next(x->stream.object0); - break; + case ecl_smm_broadcast: + case ecl_smm_concatenated: + mark_next(x->stream.object0); + break; - case ecl_smm_two_way: - case ecl_smm_echo: - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; + case ecl_smm_two_way: + case ecl_smm_echo: + mark_object(x->stream.object0); + mark_next(x->stream.object1); + break; - case ecl_smm_string_input: - case ecl_smm_string_output: - mark_next(x->stream.object0); - break; + case ecl_smm_string_input: + case ecl_smm_string_output: + mark_next(x->stream.object0); + break; - default: - error("mark stream botch"); - } - break; + default: + error("mark stream botch"); + } + break; - case t_random: - break; + case t_random: + break; - case t_readtable: - if (x->readtable.table == NULL) - break; - mark_contblock((char *)(x->readtable.table), RTABSIZE*sizeof(struct readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - cl_object *p = x->readtable.table[i].dispatch_table; - mark_object(x->readtable.table[i].macro); - if (p != NULL) { - mark_contblock(p, RTABSIZE*sizeof(cl_object)); - for (j = 0; j < RTABSIZE; j++) - mark_object(p[j]); - } - } - break; + case t_readtable: + if (x->readtable.table == NULL) + break; + mark_contblock((char *)(x->readtable.table), RTABSIZE*sizeof(struct readtable_entry)); + for (i = 0; i < RTABSIZE; i++) { + cl_object *p = x->readtable.table[i].dispatch_table; + mark_object(x->readtable.table[i].macro); + if (p != NULL) { + mark_contblock(p, RTABSIZE*sizeof(cl_object)); + for (j = 0; j < RTABSIZE; j++) + mark_object(p[j]); + } + } + break; - case t_pathname: - mark_object(x->pathname.host); - mark_object(x->pathname.device); - mark_object(x->pathname.directory); - mark_object(x->pathname.name); - mark_object(x->pathname.type); - mark_object(x->pathname.version); - break; + case t_pathname: + mark_object(x->pathname.host); + mark_object(x->pathname.device); + mark_object(x->pathname.directory); + mark_object(x->pathname.name); + mark_object(x->pathname.type); + mark_object(x->pathname.version); + break; - case t_bytecodes: { - cl_index i, size; - size = x->bytecodes.size; - mark_object(x->bytecodes.lex); - mark_contblock(x->bytecodes.data, size * sizeof(cl_object)); - for (i=0; ibytecodes.data[i]); - break; - } - case t_cfun: - mark_object(x->cfun.block); - mark_object(x->cfun.name); - break; + case t_bytecodes: { + cl_index i, size; + size = x->bytecodes.size; + mark_object(x->bytecodes.lex); + mark_contblock(x->bytecodes.data, size * sizeof(cl_object)); + for (i=0; ibytecodes.data[i]); + break; + } + case t_cfun: + mark_object(x->cfun.block); + mark_object(x->cfun.name); + break; - case t_cclosure: - mark_object(x->cfun.block); - mark_object(x->cclosure.env); - break; + case t_cclosure: + mark_object(x->cfun.block); + mark_object(x->cclosure.env); + break; #ifdef THREADS - case t_cont: - mark_next(x->cn.cn_thread); - break; + case t_cont: + mark_next(x->cn.cn_thread); + break; - case t_thread: + case t_thread: /* Already marked by malloc - mark_contblock(x->thread.data, x->thread.size); + mark_contblock(x->thread.data, x->thread.size); */ - mark_next(x->thread.entry); - break; + mark_next(x->thread.entry); + break; #endif THREADS #ifdef CLOS - case t_instance: - mark_object(x->instance.class); - p = x->instance.slots; - if (p == NULL) - break; - for (i = 0, j = x->instance.length; i < j; i++) - mark_object(p[i]); - mark_contblock(p, j*sizeof(cl_object)); - break; + case t_instance: + mark_object(x->instance.class); + p = x->instance.slots; + if (p == NULL) + break; + for (i = 0, j = x->instance.length; i < j; i++) + mark_object(p[i]); + mark_contblock(p, j*sizeof(cl_object)); + break; - case t_gfun: - mark_object(x->gfun.name); - mark_object(x->gfun.method_hash); - mark_object(x->gfun.instance); - p = x->gfun.specializers; - if (p == NULL) - break; - for (i = 0, j = x->gfun.arg_no; i < j; i++) - mark_object(p[i]); - mark_contblock(p, j*sizeof(cl_object)); - break; + case t_gfun: + mark_object(x->gfun.name); + mark_object(x->gfun.method_hash); + mark_object(x->gfun.instance); + p = x->gfun.specializers; + if (p == NULL) + break; + for (i = 0, j = x->gfun.arg_no; i < j; i++) + mark_object(p[i]); + mark_contblock(p, j*sizeof(cl_object)); + break; #endif CLOS - case t_codeblock: - mark_object(x->cblock.name); - mark_contblock(x->cblock.start, x->cblock.size); - if (x->cblock.data) { - cl_index i = x->cblock.data_size; - cl_object *p = x->cblock.data; - while (i--) - mark_object(p[i]); - } - break; - default: - if (debug) - printf("\ttype = %d\n", ecl_t_of(x)); - error("mark botch"); - } + case t_codeblock: + mark_object(x->cblock.name); + mark_contblock(x->cblock.start, x->cblock.size); + if (x->cblock.data) { + cl_index i = x->cblock.data_size; + cl_object *p = x->cblock.data; + while (i--) + mark_object(p[i]); + } + break; + default: + if (debug) + printf("\ttype = %d\n", ecl_t_of(x)); + error("mark botch"); + } } static void @@ -439,7 +439,7 @@ mark_stack_conservative(int *top, int *bottom) tm = tm_of((enum type)type_map[p]); x = (cl_object)(*j - (*j - (int)pagetochar(p)) % tm->tm_size); if (!get_mark_bit(x)) - mark_object(x); + mark_object(x); } } if (debug) {printf(". done.\n"); fflush(stdout); } @@ -448,209 +448,209 @@ mark_stack_conservative(int *top, int *bottom) static void mark_phase(void) { - register int i; - register struct package *pp; - register ecl_bds_ptr bdp; - register ecl_frame_ptr frp; - register ecl_ihs_ptr ihsp; + register int i; + register struct package *pp; + register ecl_bds_ptr bdp; + register ecl_frame_ptr frp; + register ecl_ihs_ptr ihsp; - mark_object(ECL_NIL); - mark_object(ECL_T); + mark_object(ECL_NIL); + mark_object(ECL_T); #ifdef THREADS - { - pd *pdp; - lpd *old_clwp = clwp; + { + pd *pdp; + lpd *old_clwp = clwp; - for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) { + for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) { - clwp = pdp->pd_lpd; + clwp = pdp->pd_lpd; #endif THREADS - - for (i=0; ibds_sym); - mark_object(bdp->bds_val); - } - - for (frp = frs_org; frp <= frs_top; frp++) { - mark_object(frp->frs_val); - mark_object(frp->frs_lex); - } - - for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) { - mark_object(ihsp->ihs_function); - mark_object(ihsp->ihs_base); - } + for (bdp = bds_org; bdp <= bds_top; bdp++) { + mark_object(bdp->bds_sym); + mark_object(bdp->bds_val); + } + + for (frp = frs_org; frp <= frs_top; frp++) { + mark_object(frp->frs_val); + mark_object(frp->frs_lex); + } + + for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) { + mark_object(ihsp->ihs_function); + mark_object(ihsp->ihs_base); + } - mark_object(lex_env); + mark_object(lex_env); -#ifdef THREADS - /* added to mark newly allocated objects */ - mark_object(clwp->lwp_alloc_temporary); - mark_object(clwp->lwp_fmt_temporary_stream); - mark_object(clwp->lwp_PRINTstream); - mark_object(clwp->lwp_PRINTcase); - mark_object(clwp->lwp_READtable); - mark_object(clwp->lwp_delimiting_char); - mark_object(clwp->lwp_token); +#ifdef THREADS + /* added to mark newly allocated objects */ + mark_object(clwp->lwp_alloc_temporary); + mark_object(clwp->lwp_fmt_temporary_stream); + mark_object(clwp->lwp_PRINTstream); + mark_object(clwp->lwp_PRINTcase); + mark_object(clwp->lwp_READtable); + mark_object(clwp->lwp_delimiting_char); + mark_object(clwp->lwp_token); - /* (current-thread) can return it at any time - */ - mark_object(clwp->lwp_thread); -#endif THREADS - - /* now collect from the c-stack of the thread ... */ - - { int *where; - volatile jmp_buf buf; + /* (current-thread) can return it at any time + */ + mark_object(clwp->lwp_thread); +#endif THREADS + + /* now collect from the c-stack of the thread ... */ + + { int *where; + volatile jmp_buf buf; - /* ensure flushing of register caches */ - if (ecl_setjmp(buf) == 0) ecl_longjmp(buf, 1); + /* ensure flushing of register caches */ + if (ecl_setjmp(buf) == 0) ecl_longjmp(buf, 1); #ifdef THREADS - if (clwp != old_clwp) /* is not the executing stack */ + if (clwp != old_clwp) /* is not the executing stack */ # ifdef __linux - where = (int *)pdp->pd_env[0].__jmpbuf[0].__sp; + where = (int *)pdp->pd_env[0].__jmpbuf[0].__sp; # else - where = (int *)pdp->pd_env[JB_SP]; + where = (int *)pdp->pd_env[JB_SP]; # endif - else + else #endif THREADS - where = (int *)&where ; - - /* If the locals of type object in a C function could be - aligned other than on multiples of sizeof (char *) - we would have to mark twice */ - - if (where > cs_org) - mark_stack_conservative(where, cs_org); - else - mark_stack_conservative(cs_org, where); - } + where = (int *)&where ; + + /* If the locals of type object in a C function could be + aligned other than on multiples of sizeof (char *) + we would have to mark twice */ + + if (where > cs_org) + mark_stack_conservative(where, cs_org); + else + mark_stack_conservative(cs_org, where); + } #ifdef THREADS - } - clwp = old_clwp; - } + } + clwp = old_clwp; + } #endif THREADS - /* mark roots */ - for (i = 0; i < gc_roots; i++) - mark_object(*gc_root[i]); + /* mark roots */ + for (i = 0; i < gc_roots; i++) + mark_object(*gc_root[i]); - /* mark registered symbols & keywords */ - { - const struct keyword_info *k; - const struct symbol_info *s; - for (k = all_keywords; k->loc != NULL; k++) - mark_object(*(k->loc)); - for (s = all_symbols; s->loc != NULL; s++) - mark_object(*(s->loc)); - } + /* mark registered symbols & keywords */ + { + const struct keyword_info *k; + const struct symbol_info *s; + for (k = all_keywords; k->loc != NULL; k++) + mark_object(*(k->loc)); + for (s = all_symbols; s->loc != NULL; s++) + mark_object(*(s->loc)); + } - if (debug) { - printf("symbol navigation\n"); - fflush(stdout); - } + if (debug) { + printf("symbol navigation\n"); + fflush(stdout); + } } static void sweep_phase(void) { - register int i, j, k; - register cl_object x; - register char *p; - register struct typemanager *tm; - register cl_object f; + register int i, j, k; + register cl_object x; + register char *p; + register struct typemanager *tm; + register cl_object f; - ECL_NIL->symbol.m = FALSE; - ECL_T->symbol.m = FALSE; + ECL_NIL->symbol.m = FALSE; + ECL_T->symbol.m = FALSE; - if (debug) - printf("type map\n"); + if (debug) + printf("type map\n"); - for (i = 0; i < maxpage; i++) { - if (type_map[i] == (int)t_contiguous) { - if (debug) { - printf("-"); - continue; - } - } - if (type_map[i] >= (int)t_end) - continue; + for (i = 0; i < maxpage; i++) { + if (type_map[i] == (int)t_contiguous) { + if (debug) { + printf("-"); + continue; + } + } + if (type_map[i] >= (int)t_end) + continue; - tm = tm_of((enum type)type_map[i]); + tm = tm_of((enum type)type_map[i]); - /* - general sweeper - */ + /* + general sweeper + */ - if (debug) - printf("%c", tm->tm_name[0]); + if (debug) + printf("%c", tm->tm_name[0]); - p = pagetochar(i); - f = tm->tm_free; - k = 0; - for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { - x = (cl_object)p; - if (!get_mark_bit(x)) { - ((struct freelist *)x)->f_link = f; - f = x; - k++; - } - } - tm->tm_free = f; - tm->tm_nfree += k; - tm->tm_nused -= k; - } + p = pagetochar(i); + f = tm->tm_free; + k = 0; + for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { + x = (cl_object)p; + if (!get_mark_bit(x)) { + ((struct freelist *)x)->f_link = f; + f = x; + k++; + } + } + tm->tm_free = f; + tm->tm_nfree += k; + tm->tm_nused -= k; + } - if (debug) { - putchar('\n'); - fflush(stdout); - } + if (debug) { + putchar('\n'); + fflush(stdout); + } } static void contblock_sweep_phase(void) { - register int i, j; - register char *s, *e, *p, *q; - register struct contblock *cbp; + register int i, j; + register char *s, *e, *p, *q; + register struct contblock *cbp; - cb_pointer = NULL; - ncb = 0; - for (i = 0; i < maxpage;) { - if (type_map[i] != (int)t_contiguous) { - i++; - continue; - } - for (j = i+1; - j < maxpage && type_map[j] == (int)t_contiguous; - j++) - ; - s = pagetochar(i); - e = pagetochar(j); - for (p = s; p < e;) { - if (get_mark_bit((int *)p)) { - p += 4; - continue; - } - q = p + 4; - while (q < e && !get_mark_bit((int *)q)) - q += 4; - dealloc(p, q - p); - p = q + 4; - } - i = j + 1; - } + cb_pointer = NULL; + ncb = 0; + for (i = 0; i < maxpage;) { + if (type_map[i] != (int)t_contiguous) { + i++; + continue; + } + for (j = i+1; + j < maxpage && type_map[j] == (int)t_contiguous; + j++) + ; + s = pagetochar(i); + e = pagetochar(j); + for (p = s; p < e;) { + if (get_mark_bit((int *)p)) { + p += 4; + continue; + } + q = p + 4; + while (q < e && !get_mark_bit((int *)q)) + q += 4; + dealloc(p, q - p); + p = q + 4; + } + i = j + 1; + } - if (debug) { - for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) - printf("0x%p %d\n", cbp, cbp->cb_size); - fflush(stdout); - } + if (debug) { + for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) + printf("0x%p %d\n", cbp, cbp->cb_size); + fflush(stdout); + } } cl_object (*GC_enter_hook)() = NULL; @@ -677,11 +677,11 @@ static enum type garbage_parameter; void gc(enum type new_name) { - int tm; - int gc_start = runtime(); + int tm; + int gc_start = runtime(); - start_critical_section(); - t = new_name; + start_critical_section(); + t = new_name; garbage_parameter = new_name; #else @@ -749,9 +749,9 @@ gc(enum type t) if (debug) { if (collect_blocks) - printf("GC entered for collecting blocks\n"); + printf("GC entered for collecting blocks\n"); else - printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); + printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); fflush(stdout); } @@ -759,21 +759,21 @@ gc(enum type t) if (collect_blocks) { /* - 1 page = 512 word - 512 bit = 16 word + 1 page = 512 word + 512 bit = 16 word */ int mark_table_size = maxpage * (LISP_PAGESIZE / 32); extern void resize_hole(size_t); if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) - new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; + new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; if (new_holepage < HOLEPAGE) - new_holepage = HOLEPAGE; + new_holepage = HOLEPAGE; resize_hole(new_holepage); mark_table = (int*)heap_end; for (i = 0; i < mark_table_size; i++) - mark_table[i] = 0; + mark_table[i] = 0; } if (debug) { @@ -796,29 +796,29 @@ gc(enum type t) if (t == t_contiguous) { if (debug) { - printf("contblock sweep phase\n"); - fflush(stdout); - tm = runtime(); + printf("contblock sweep phase\n"); + fflush(stdout); + tm = runtime(); } contblock_sweep_phase(); if (debug) - printf("contblock sweep ended (%d)\n", runtime() - tm); + printf("contblock sweep ended (%d)\n", runtime() - tm); } if (debug) { for (i = 0, j = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (enum type)i) { - printf("%13s: %8d used %8d free %4d/%d pages\n", - tm_table[i].tm_name, - tm_table[i].tm_nused, - tm_table[i].tm_nfree, - tm_table[i].tm_npage, - tm_table[i].tm_maxpage); - j += tm_table[i].tm_npage; - } else - printf("%13s: linked to %s\n", - tm_table[i].tm_name, - tm_table[(int)tm_table[i].tm_type].tm_name); + if (tm_table[i].tm_type == (enum type)i) { + printf("%13s: %8d used %8d free %4d/%d pages\n", + tm_table[i].tm_name, + tm_table[i].tm_nused, + tm_table[i].tm_nfree, + tm_table[i].tm_npage, + tm_table[i].tm_maxpage); + j += tm_table[i].tm_npage; + } else + printf("%13s: linked to %s\n", + tm_table[i].tm_name, + tm_table[(int)tm_table[i].tm_type].tm_name); } printf("contblock: %d blocks %d pages\n", ncb, ncbpage); printf("hole: %d pages\n", holepage); @@ -839,14 +839,14 @@ gc(enum type t) if (stack_switched) { if (debug) { - printf("*STACK BACK*\n"); - fflush (stdout); + printf("*STACK BACK*\n"); + fflush (stdout); } stack_switched = FALSE; - end_critical_section(); /* we get here from the GC call in scheduler */ - + end_critical_section(); /* we get here from the GC call in scheduler */ + clwp = old_clwp; Values = clwp->lwp_Values; siglongjmp(old_env, 2); @@ -879,10 +879,10 @@ gc(enum type t) * Both p and p+s are rounded to word boundaries. * * Results: - * none. + * none. * * Side effects: - * mark_table + * mark_table * *---------------------------------------------------------------------- */ @@ -890,49 +890,49 @@ gc(enum type t) static void _mark_contblock(void *x, size_t s) { - register char *p = x, *q; - register ptrdiff_t pg = page(p); + register char *p = x, *q; + register ptrdiff_t pg = page(p); - if (pg < 0 || (enum type)type_map[pg] != t_contiguous) - return; + if (pg < 0 || (enum type)type_map[pg] != t_contiguous) + return; #if 1 - q = p + s; - p = (char *)((int)p&~3); - q = (char *)(((int)q+3)&~3); - for (; p < q; p+= 4) - set_mark_bit(p); + q = p + s; + p = (char *)((int)p&~3); + q = (char *)(((int)q+3)&~3); + for (; p < q; p+= 4) + set_mark_bit(p); #elif 0 - { - int bit_start = ((int)p - DATA_START) >> 2; - int bit_end = ((int)p + s + 3 - DATA_START) >> 2; - int *w = &mark_table[bit_start >> 5]; - int b = bit_start & (32 - 1); - int mask = ~0 << b; - int bits = b + bit_end - bit_start; - while (bits >= 32) { - *w |= mask; - w++; - bits -= 32; - mask = ~0; - } - mask &= ~(~0 << bits); - *w |= mask; - } + { + int bit_start = ((int)p - DATA_START) >> 2; + int bit_end = ((int)p + s + 3 - DATA_START) >> 2; + int *w = &mark_table[bit_start >> 5]; + int b = bit_start & (32 - 1); + int mask = ~0 << b; + int bits = b + bit_end - bit_start; + while (bits >= 32) { + *w |= mask; + w++; + bits -= 32; + mask = ~0; + } + mask &= ~(~0 << bits); + *w |= mask; + } #else - { - int bit_start = ((int)p - DATA_START) >> 2; - int bits = ((int)p + s + 3 - DATA_START) >> 2 - bit_start; - int mask = 1 << bit_start & (32 - 1); - int *w = &mark_table[bit_start >> 5]; - while (bits) { - *w |= mask; - mask <<= 1; - if (!mask) { - mask = 1; - w++; - } - } - } + { + int bit_start = ((int)p - DATA_START) >> 2; + int bits = ((int)p + s + 3 - DATA_START) >> 2 - bit_start; + int mask = 1 << bit_start & (32 - 1); + int *w = &mark_table[bit_start >> 5]; + while (bits) { + *w |= mask; + mask <<= 1; + if (!mask) { + mask = 1; + w++; + } + } + } #endif } @@ -942,58 +942,58 @@ _mark_contblock(void *x, size_t s) */ @(defun si::room-report () - int i; - cl_object *tl; + int i; + cl_object *tl; @ - NValues = 8; - VALUES(0) = ecl_make_fixnum(real_maxpage); - VALUES(1) = ecl_make_fixnum(available_pages()); - VALUES(2) = ecl_make_fixnum(ncbpage); - VALUES(3) = ecl_make_fixnum(maxcbpage); - VALUES(4) = ecl_make_fixnum(ncb); - VALUES(5) = ecl_make_fixnum(cbgccount); - VALUES(6) = ecl_make_fixnum(holepage); - VALUES(7) = ECL_NIL; - tl = &VALUES(7); - for (i = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (enum type)i) { - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); - } else { - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - } - } - return VALUES(0); + NValues = 8; + VALUES(0) = ecl_make_fixnum(real_maxpage); + VALUES(1) = ecl_make_fixnum(available_pages()); + VALUES(2) = ecl_make_fixnum(ncbpage); + VALUES(3) = ecl_make_fixnum(maxcbpage); + VALUES(4) = ecl_make_fixnum(ncb); + VALUES(5) = ecl_make_fixnum(cbgccount); + VALUES(6) = ecl_make_fixnum(holepage); + VALUES(7) = ECL_NIL; + tl = &VALUES(7); + for (i = 0; i < (int)t_end; i++) { + if (tm_table[i].tm_type == (enum type)i) { + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); + } else { + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + } + } + return VALUES(0); @) @(defun si::reset-gc-count () - int i; + int i; @ - cbgccount = 0; - for (i = 0; i < (int)t_end; i++) - tm_table[i].tm_gccount = 0; - @(return) + cbgccount = 0; + for (i = 0; i < (int)t_end; i++) + tm_table[i].tm_gccount = 0; + @(return) @) @(defun si::gc-time () @ - @(return ecl_make_fixnum(gc_time)) + @(return ecl_make_fixnum(gc_time)) @) void init_GC(void) { - register_root(&siVgc_verbose); - register_root(&siVgc_message); - siVgc_verbose = make_si_special("*GC-VERBOSE*", ECL_NIL); - siVgc_message = make_si_special("*GC-MESSAGE*", ECL_NIL); - GC_enable(); - gc_time = 0; + register_root(&siVgc_verbose); + register_root(&siVgc_message); + siVgc_verbose = make_si_special("*GC-VERBOSE*", ECL_NIL); + siVgc_message = make_si_special("*GC-MESSAGE*", ECL_NIL); + GC_enable(); + gc_time = 0; } diff --git a/src/c/gbc.d b/src/c/gbc.d index 7329c3cc3..b30910977 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -35,10 +35,10 @@ bool GC_enable; Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f. */ -static int *mark_table; +static int *mark_table; -#define MTbit(x) ((ptr2int(x) >> 2) & 0x1f) -#define MTword(x) mark_table[((cl_ptr)x - heap_start) >> 7] +#define MTbit(x) ((ptr2int(x) >> 2) & 0x1f) +#define MTword(x) mark_table[((cl_ptr)x - heap_start) >> 7] #define get_mark_bit(x) (MTword(x) >> MTbit(x) & 1) #define set_mark_bit(x) (MTword(x) |= (1 << MTbit(x))) #define clear_mark_bit(x) (MTword(x) ~= (~1 << MTbit(x))) @@ -46,16 +46,16 @@ static int *mark_table; #define VALID_DATA_ADDRESS(pp) \ (!ECL_IMMEDIATE(pp) && (heap_start <= (cl_ptr)(pp)) && ((cl_ptr)(pp) < heap_end)) -static bool debug = FALSE; -static int maxpage; +static bool debug = FALSE; +static int maxpage; -#define GC_ROOT_MAX 200 -static cl_object *gc_root[GC_ROOT_MAX]; -static int gc_roots; +#define GC_ROOT_MAX 200 +static cl_object *gc_root[GC_ROOT_MAX]; +static int gc_roots; -static bool collect_blocks; +static bool collect_blocks; -static int gc_time; /* Beppe */ +static int gc_time; /* Beppe */ /* We must register location, since value may be reassigned (e.g. malloc_list) @@ -69,21 +69,21 @@ extern void sigint (void); void ecl_register_root(cl_object *p) { - if (gc_roots >= GC_ROOT_MAX) - ecl_internal_error("too many roots"); - gc_root[gc_roots++] = p; + if (gc_roots >= GC_ROOT_MAX) + ecl_internal_error("too many roots"); + gc_root[gc_roots++] = p; } cl_object si_gc(cl_object area) { - if (!GC_enabled()) - ecl_internal_error("GC is not enabled"); - if (Null(area)) - ecl_gc(t_cons); - else - ecl_gc(t_contiguous); - @(return) + if (!GC_enabled()) + ecl_internal_error("GC is not enabled"); + if (Null(area)) + ecl_gc(t_cons); + else + ecl_gc(t_contiguous); + @(return) } /*---------------------------------------------------------------------- @@ -110,430 +110,430 @@ si_gc(cl_object area) static void _mark_object(cl_object x) { - cl_index i, j; - cl_object *p, y; - cl_ptr cp; + cl_index i, j; + cl_object *p, y; + cl_ptr cp; BEGIN: #if 0 - /* We cannot get here because mark_object() and mark_next() already check this */ - if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ - if (x == OBJNULL) - return; + /* We cannot get here because mark_object() and mark_next() already check this */ + if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */ + if (x == OBJNULL) + return; #endif - /* We need this, because sometimes we arrive to data structures - * which have been created in the C stack (t_frame in gfun.d, - * for instance) */ - if (!VALID_DATA_ADDRESS(x)) - return; - if (x->d.m) { - if (x->d.m == FREE) - ecl_internal_error("mark_object: pointer to free object."); - else - return; - } - x->d.m = TRUE; + /* We need this, because sometimes we arrive to data structures + * which have been created in the C stack (t_frame in gfun.d, + * for instance) */ + if (!VALID_DATA_ADDRESS(x)) + return; + if (x->d.m) { + if (x->d.m == FREE) + ecl_internal_error("mark_object: pointer to free object."); + else + return; + } + x->d.m = TRUE; - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { - case t_bignum: { - /* GMP may set num.alloc before actually allocating anything. - With these checks we make sure we do not move anything - we don't have to. Besides, we use big_dim as the size - of the object, because big_size might even be smaller. - */ - cl_ptr limbs = (cl_ptr)x->big.big_limbs; - cl_index size = x->big.big_dim * sizeof(mp_limb_t); - if (size) mark_contblock(limbs, size); - break; - } - case t_ratio: - mark_object(x->ratio.num); - mark_next(x->ratio.den); - break; + case t_bignum: { + /* GMP may set num.alloc before actually allocating anything. + With these checks we make sure we do not move anything + we don't have to. Besides, we use big_dim as the size + of the object, because big_size might even be smaller. + */ + cl_ptr limbs = (cl_ptr)x->big.big_limbs; + cl_index size = x->big.big_dim * sizeof(mp_limb_t); + if (size) mark_contblock(limbs, size); + break; + } + case t_ratio: + mark_object(x->ratio.num); + mark_next(x->ratio.den); + break; #ifdef ECL_SSE2 - case t_sse_pack: + case t_sse_pack: #endif - case t_singlefloat: - case t_doublefloat: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - break; + break; - case t_complex: - mark_object(x->complex.imag); - mark_next(x->complex.real); - break; + case t_complex: + mark_object(x->complex.imag); + mark_next(x->complex.real); + break; - case t_character: - break; + case t_character: + break; - case t_symbol: - mark_object(x->symbol.hpack); - mark_object(x->symbol.name); - mark_object(x->symbol.plist); - mark_object(x->symbol.gfdef); - mark_next(x->symbol.value); - break; + case t_symbol: + mark_object(x->symbol.hpack); + mark_object(x->symbol.name); + mark_object(x->symbol.plist); + mark_object(x->symbol.gfdef); + mark_next(x->symbol.value); + break; - case t_package: - mark_object(x->pack.name); - mark_object(x->pack.nicknames); - mark_object(x->pack.shadowings); - mark_object(x->pack.uses); - mark_object(x->pack.usedby); - mark_object(x->pack.internal); - mark_next(x->pack.external); - break; + case t_package: + mark_object(x->pack.name); + mark_object(x->pack.nicknames); + mark_object(x->pack.shadowings); + mark_object(x->pack.uses); + mark_object(x->pack.usedby); + mark_object(x->pack.internal); + mark_next(x->pack.external); + break; - case t_cons: - mark_object(CAR(x)); - mark_next(CDR(x)); - break; + case t_cons: + mark_object(CAR(x)); + mark_next(CDR(x)); + break; - case t_hashtable: - mark_object(x->hash.rehash_size); - mark_object(x->hash.threshold); - if (x->hash.data == NULL) - break; - for (i = 0, j = x->hash.size; i < j; i++) { - mark_object(x->hash.data[i].key); - mark_object(x->hash.data[i].value); - } - mark_contblock(x->hash.data, j * sizeof(struct ecl_hashtable_entry)); - break; + case t_hashtable: + mark_object(x->hash.rehash_size); + mark_object(x->hash.threshold); + if (x->hash.data == NULL) + break; + for (i = 0, j = x->hash.size; i < j; i++) { + mark_object(x->hash.data[i].key); + mark_object(x->hash.data[i].value); + } + mark_contblock(x->hash.data, j * sizeof(struct ecl_hashtable_entry)); + break; - case t_array: - mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); + case t_array: + mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - if ((y = x->array.displaced) != ECL_NIL) - mark_displaced(y); - cp = (cl_ptr)x->array.self.t; - if (cp == NULL) - break; - switch ((cl_elttype)x->array.elttype) { + case t_vector: + if ((y = x->array.displaced) != ECL_NIL) + mark_displaced(y); + cp = (cl_ptr)x->array.self.t; + if (cp == NULL) + break; + switch ((cl_elttype)x->array.elttype) { #ifdef ECL_UNICODE - case ecl_aet_ch: + case ecl_aet_ch: #endif - case ecl_aet_object: - if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { - i = x->vector.dim; - p = x->array.self.t; - goto MARK_DATA; - } - j = sizeof(cl_object)*x->array.dim; - break; - case ecl_aet_bc: - j = x->array.dim; - break; - case ecl_aet_bit: - j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - break; - case ecl_aet_fix: - j = x->array.dim * sizeof(cl_fixnum); - break; - case ecl_aet_index: - j = x->array.dim * sizeof(cl_index); - break; - case ecl_aet_sf: - j = x->array.dim * sizeof(float); - break; - case ecl_aet_df: - j = x->array.dim * sizeof(double); - break; - case ecl_aet_b8: - j = x->array.dim * sizeof(uint8_t); - break; - case ecl_aet_i8: - j = x->array.dim * sizeof(int8_t); - break; - default: - ecl_internal_error("Allocation botch: unknown array element type"); - } - goto COPY_ARRAY; - case t_base_string: - if ((y = x->base_string.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->base_string.self; - if (cp == NULL) - break; - j = x->base_string.dim+1; - COPY_ARRAY: - mark_contblock(cp, j); - break; - case t_bitvector: - if ((y = x->vector.displaced) != ECL_NIL) - mark_displaced(y); - cp = x->vector.self.bit; - if (cp == NULL) - break; - j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); - goto COPY_ARRAY; + case ecl_aet_object: + if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) { + i = x->vector.dim; + p = x->array.self.t; + goto MARK_DATA; + } + j = sizeof(cl_object)*x->array.dim; + break; + case ecl_aet_bc: + j = x->array.dim; + break; + case ecl_aet_bit: + j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); + break; + case ecl_aet_fix: + j = x->array.dim * sizeof(cl_fixnum); + break; + case ecl_aet_index: + j = x->array.dim * sizeof(cl_index); + break; + case ecl_aet_sf: + j = x->array.dim * sizeof(float); + break; + case ecl_aet_df: + j = x->array.dim * sizeof(double); + break; + case ecl_aet_b8: + j = x->array.dim * sizeof(uint8_t); + break; + case ecl_aet_i8: + j = x->array.dim * sizeof(int8_t); + break; + default: + ecl_internal_error("Allocation botch: unknown array element type"); + } + goto COPY_ARRAY; + case t_base_string: + if ((y = x->base_string.displaced) != ECL_NIL) + mark_displaced(y); + cp = x->base_string.self; + if (cp == NULL) + break; + j = x->base_string.dim+1; + COPY_ARRAY: + mark_contblock(cp, j); + break; + case t_bitvector: + if ((y = x->vector.displaced) != ECL_NIL) + mark_displaced(y); + cp = x->vector.self.bit; + if (cp == NULL) + break; + j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE); + goto COPY_ARRAY; #ifndef CLOS - case t_structure: - mark_object(x->str.name); - p = x->str.self; - i = x->str.length; - goto MARK_DATA; + case t_structure: + mark_object(x->str.name); + p = x->str.self; + i = x->str.length; + goto MARK_DATA; #endif /* CLOS */ - case t_stream: - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - case ecl_smm_probe: - mark_contblock(x->stream.buffer, BUFSIZ); - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; + case t_stream: + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: + case ecl_smm_probe: + mark_contblock(x->stream.buffer, BUFSIZ); + mark_object(x->stream.object0); + mark_next(x->stream.object1); + break; - case ecl_smm_synonym: - mark_next(x->stream.object0); - break; + case ecl_smm_synonym: + mark_next(x->stream.object0); + break; - case ecl_smm_broadcast: - case ecl_smm_concatenated: - mark_next(x->stream.object0); - break; + case ecl_smm_broadcast: + case ecl_smm_concatenated: + mark_next(x->stream.object0); + break; - case ecl_smm_two_way: - case ecl_smm_echo: - mark_object(x->stream.object0); - mark_next(x->stream.object1); - break; + case ecl_smm_two_way: + case ecl_smm_echo: + mark_object(x->stream.object0); + mark_next(x->stream.object1); + break; - case ecl_smm_string_input: - case ecl_smm_string_output: - mark_next(x->stream.object0); - break; + case ecl_smm_string_input: + case ecl_smm_string_output: + mark_next(x->stream.object0); + break; - default: - ecl_internal_error("mark stream botch"); - } - break; + default: + ecl_internal_error("mark stream botch"); + } + break; - case t_random: - break; + case t_random: + break; - case t_readtable: - if (x->readtable.table == NULL) - break; - mark_contblock((cl_ptr)(x->readtable.table), - RTABSIZE*sizeof(struct ecl_readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - cl_object *p = x->readtable.table[i].dispatch_table; - mark_object(x->readtable.table[i].macro); - if (p != NULL) { - mark_contblock(p, RTABSIZE*sizeof(cl_object)); - for (j = 0; j < RTABSIZE; j++) - mark_object(p[j]); - } - } - break; + case t_readtable: + if (x->readtable.table == NULL) + break; + mark_contblock((cl_ptr)(x->readtable.table), + RTABSIZE*sizeof(struct ecl_readtable_entry)); + for (i = 0; i < RTABSIZE; i++) { + cl_object *p = x->readtable.table[i].dispatch_table; + mark_object(x->readtable.table[i].macro); + if (p != NULL) { + mark_contblock(p, RTABSIZE*sizeof(cl_object)); + for (j = 0; j < RTABSIZE; j++) + mark_object(p[j]); + } + } + break; - case t_pathname: - mark_object(x->pathname.host); - mark_object(x->pathname.device); - mark_object(x->pathname.version); - mark_object(x->pathname.name); - mark_object(x->pathname.type); - mark_next(x->pathname.directory); - break; + case t_pathname: + mark_object(x->pathname.host); + mark_object(x->pathname.device); + mark_object(x->pathname.version); + mark_object(x->pathname.name); + mark_object(x->pathname.type); + mark_next(x->pathname.directory); + break; - case t_bytecodes: - mark_object(x->bytecodes.name); - mark_object(x->bytecodes.lex); - mark_object(x->bytecodes.specials); - mark_object(x->bytecodes.definition); - mark_contblock(x->bytecodes.code, x->bytecodes.code_size * sizeof(cl_opcode)); - mark_next(x->bytecodes.data); - break; + case t_bytecodes: + mark_object(x->bytecodes.name); + mark_object(x->bytecodes.lex); + mark_object(x->bytecodes.specials); + mark_object(x->bytecodes.definition); + mark_contblock(x->bytecodes.code, x->bytecodes.code_size * sizeof(cl_opcode)); + mark_next(x->bytecodes.data); + break; - case t_bclosure: - mark_object(x->bclosure.code); - mark_next(x->bclosure.lex); - break; + case t_bclosure: + mark_object(x->bclosure.code); + mark_next(x->bclosure.lex); + break; - case t_cfun: - case t_cfunfixed: - mark_object(x->cfun.block); - mark_next(x->cfun.name); - break; + case t_cfun: + case t_cfunfixed: + mark_object(x->cfun.block); + mark_next(x->cfun.name); + break; - case t_cclosure: - mark_object(x->cfun.block); - mark_next(x->cclosure.env); - break; + case t_cclosure: + mark_object(x->cfun.block); + mark_next(x->cclosure.env); + break; #ifdef ECL_THREADS - case t_process: + case t_process: /* Already marked by malloc: x->process.env */ - mark_object(x->process.name); - mark_object(x->process.interrupt); - mark_object(x->process.function); - mark_cl_env(x->process.env); - mark_next(x->process.args); - break; - case t_lock: - mark_next(x->lock.name); - mark_next(x->lock.holder); - break; - case t_condition_variable: + mark_object(x->process.name); + mark_object(x->process.interrupt); + mark_object(x->process.function); + mark_cl_env(x->process.env); + mark_next(x->process.args); + break; + case t_lock: + mark_next(x->lock.name); + mark_next(x->lock.holder); + break; + case t_condition_variable: break; #endif /* THREADS */ #ifdef ECL_SEMAPHORES - case t_semaphore: + case t_semaphore: break; #endif #ifdef CLOS - case t_instance: - mark_object(x->instance.clas); - mark_object(x->instance.sig); - p = x->instance.slots; - i = x->instance.length; - goto MARK_DATA; + case t_instance: + mark_object(x->instance.clas); + mark_object(x->instance.sig); + p = x->instance.slots; + i = x->instance.length; + goto MARK_DATA; #endif /* CLOS */ - case t_codeblock: - mark_object(x->cblock.name); - mark_object(x->cblock.next); - mark_object(x->cblock.links); - p = x->cblock.temp_data; - if (p) { - i = x->cblock.temp_data_size; - mark_contblock(p, i * sizeof(cl_object)); - while (i-- > 0) - mark_object(p[i]); - } - i = x->cblock.data_size; - p = x->cblock.data; - goto MARK_DATA; - case t_foreign: - if (x->foreign.size) - mark_contblock(x->foreign.data, x->foreign.size); - mark_next(x->foreign.tag); - break; - MARK_DATA: - if (p) { - mark_contblock(p, i * sizeof(cl_object)); - while (i-- > 0) - mark_object(p[i]); - } - return; - default: - if (debug) - printf("\ttype = %d\n", ecl_t_of(x)); - ecl_internal_error("mark botch"); - } + case t_codeblock: + mark_object(x->cblock.name); + mark_object(x->cblock.next); + mark_object(x->cblock.links); + p = x->cblock.temp_data; + if (p) { + i = x->cblock.temp_data_size; + mark_contblock(p, i * sizeof(cl_object)); + while (i-- > 0) + mark_object(p[i]); + } + i = x->cblock.data_size; + p = x->cblock.data; + goto MARK_DATA; + case t_foreign: + if (x->foreign.size) + mark_contblock(x->foreign.data, x->foreign.size); + mark_next(x->foreign.tag); + break; + MARK_DATA: + if (p) { + mark_contblock(p, i * sizeof(cl_object)); + while (i-- > 0) + mark_object(p[i]); + } + return; + default: + if (debug) + printf("\ttype = %d\n", ecl_t_of(x)); + ecl_internal_error("mark botch"); + } } static void mark_stack_conservative(cl_ptr bottom, cl_ptr top) { - int p, m; - cl_object x; - struct typemanager *tm; - cl_ptr j; + int p, m; + cl_object x; + struct typemanager *tm; + cl_ptr j; - if (debug) { printf("Traversing C stack .."); fflush(stdout); } + if (debug) { printf("Traversing C stack .."); fflush(stdout); } - /* On machines which align local pointers on multiple of 2 rather - than 4 we need to mark twice + /* On machines which align local pointers on multiple of 2 rather + than 4 we need to mark twice - if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0); - */ - for (j = bottom ; j < top ; j+=sizeof(cl_ptr)) { - cl_ptr aux = *((cl_ptr*)j); - /* improved Beppe: */ - if (VALID_DATA_ADDRESS(aux) && type_map[p = page(aux)] < (char)t_end) { - tm = tm_of((cl_type)type_map[p]); - x = (cl_object)(aux - (aux - pagetochar(p)) % tm->tm_size); - m = x->d.m; - if (m != FREE && m != TRUE) { - if (m) { - fprintf(stderr, - "** bad value %d of d.m in gc page %d skipping mark **", - m, p); fflush(stderr); - } else { - mark_object(x); - } - } - } - } - if (debug) { - printf(". done.\n"); fflush(stdout); - } + if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0); + */ + for (j = bottom ; j < top ; j+=sizeof(cl_ptr)) { + cl_ptr aux = *((cl_ptr*)j); + /* improved Beppe: */ + if (VALID_DATA_ADDRESS(aux) && type_map[p = page(aux)] < (char)t_end) { + tm = tm_of((cl_type)type_map[p]); + x = (cl_object)(aux - (aux - pagetochar(p)) % tm->tm_size); + m = x->d.m; + if (m != FREE && m != TRUE) { + if (m) { + fprintf(stderr, + "** bad value %d of d.m in gc page %d skipping mark **", + m, p); fflush(stderr); + } else { + mark_object(x); + } + } + } + } + if (debug) { + printf(". done.\n"); fflush(stdout); + } } static void mark_cl_env(struct cl_env_struct *env) { - int i = 0; - cl_object where = 0; - ecl_bds_ptr bdp = 0; - ecl_frame_ptr frp = 0; - ecl_ihs_ptr ihs = 0; + int i = 0; + cl_object where = 0; + ecl_bds_ptr bdp = 0; + ecl_frame_ptr frp = 0; + ecl_ihs_ptr ihs = 0; - mark_contblock(env, sizeof(*env)); + mark_contblock(env, sizeof(*env)); - mark_object(env->lex_env); + mark_object(env->lex_env); - mark_contblock(env->stack, env->stack_size * sizeof(cl_object)); - mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top); + mark_contblock(env->stack, env->stack_size * sizeof(cl_object)); + mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top); - if ((bdp = env->bds_org)) { - mark_contblock(bdp, env->bds_size * sizeof(*bdp)); - for (; bdp <= env->bds_top; bdp++) { - mark_object(bdp->symbol); - mark_object(bdp->value); - } - } - mark_object(env->bindings_hash); + if ((bdp = env->bds_org)) { + mark_contblock(bdp, env->bds_size * sizeof(*bdp)); + for (; bdp <= env->bds_top; bdp++) { + mark_object(bdp->symbol); + mark_object(bdp->value); + } + } + mark_object(env->bindings_hash); - if ((frp = env->frs_org)) { - mark_contblock(frp, env->frs_size * sizeof(*frp)); - for (; frp <= env->frs_top; frp++) { - mark_object(frp->frs_val); - } - } + if ((frp = env->frs_org)) { + mark_contblock(frp, env->frs_size * sizeof(*frp)); + for (; frp <= env->frs_top; frp++) { + mark_object(frp->frs_val); + } + } - for (ihs = env->ihs_top; ihs; ihs = ihs->next) { - mark_object(ihs->function); - mark_object(ihs->lex_env); - } + for (ihs = env->ihs_top; ihs; ihs = ihs->next) { + mark_object(ihs->function); + mark_object(ihs->lex_env); + } - for (i=0; invalues; i++) - mark_object(env->values[i]); + for (i=0; invalues; i++) + mark_object(env->values[i]); - mark_object(env->string_pool); + mark_object(env->string_pool); - if (env->c_env) { - mark_object(env->c_env->variables); - mark_object(env->c_env->macros); - mark_object(env->c_env->constants); - } + if (env->c_env) { + mark_object(env->c_env->variables); + mark_object(env->c_env->macros); + mark_object(env->c_env->constants); + } - mark_object(env->fmt_aux_stream); + mark_object(env->fmt_aux_stream); - mark_contblock(env->queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE); - mark_contblock(env->indent_stack, sizeof(short) * ECL_PPRINT_INDENTATION_STACK_SIZE); + mark_contblock(env->queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE); + mark_contblock(env->indent_stack, sizeof(short) * ECL_PPRINT_INDENTATION_STACK_SIZE); - mark_object(env->big_register[0]); - mark_object(env->big_register[1]); - mark_object(env->big_register[2]); + mark_object(env->big_register[0]); + mark_object(env->big_register[1]); + mark_object(env->big_register[2]); #ifdef CLOS #ifdef ECL_THREADS - mark_object(env->method_hash_clear_list); + mark_object(env->method_hash_clear_list); #endif - mark_object(env->method_hash); - mark_object(env->method_spec_vector); + mark_object(env->method_hash); + mark_object(env->method_spec_vector); #endif #ifdef ECL_THREADS @@ -541,199 +541,199 @@ mark_cl_env(struct cl_env_struct *env) #error "The old garbage collector does not support threads" #else # ifdef ECL_DOWN_STACK - mark_stack_conservative((cl_ptr)(&where), (cl_ptr)env->cs_org); + mark_stack_conservative((cl_ptr)(&where), (cl_ptr)env->cs_org); # else - mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where)); + mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where)); # endif /* ECL_DOWN_STACK */ #endif /* THREADS */ #ifdef ECL_FFICALL - mark_contblock(env->fficall, sizeof(struct ecl_fficall)); - mark_object(((struct ecl_fficall*)env->fficall)->cstring); + mark_contblock(env->fficall, sizeof(struct ecl_fficall)); + mark_object(((struct ecl_fficall*)env->fficall)->cstring); #endif } static void mark_phase(void) { - int i; - cl_object s; + int i; + cl_object s; - /* save registers on the stack */ - jmp_buf volatile registers; - ecl_setjmp(registers); + /* save registers on the stack */ + jmp_buf volatile registers; + ecl_setjmp(registers); - /* mark registered symbols & keywords */ - for (i=0; isymbol.m = FALSE; - } - for (i=0; isymbol.m = FALSE; + } + for (i=0; ivector.fillp; i++) { - cl_object dll = s->vector.self.t[i]; - if (dll->cblock.locked) { - mark_object(dll); - } - } - s->vector.elttype = ecl_aet_fix; - mark_object(s); - s->vector.elttype = ecl_aet_object; - } - mark_stack_conservative((cl_ptr)&cl_core, (cl_ptr)(&cl_core + 1)); - /* mark roots */ - for (i = 0; i < gc_roots; i++) - mark_object(*gc_root[i]); + /* We mark everything, but we do not want to get the loaded + * libraries to be marked unless they are referenced somewhere + * else (function definition. etc) */ + s = cl_core.libraries; + if (s) { + for (i = 0; i < s->vector.fillp; i++) { + cl_object dll = s->vector.self.t[i]; + if (dll->cblock.locked) { + mark_object(dll); + } + } + s->vector.elttype = ecl_aet_fix; + mark_object(s); + s->vector.elttype = ecl_aet_object; + } + mark_stack_conservative((cl_ptr)&cl_core, (cl_ptr)(&cl_core + 1)); + /* mark roots */ + for (i = 0; i < gc_roots; i++) + mark_object(*gc_root[i]); #ifdef ECL_THREADS - mark_object(cl_core.processes); + mark_object(cl_core.processes); #else - mark_cl_env(&cl_env); + mark_cl_env(&cl_env); #endif } static void sweep_phase(void) { - register int i, j, k; - register cl_object x; - register cl_ptr p; - register struct typemanager *tm; - register cl_object f; + register int i, j, k; + register cl_object x; + register cl_ptr p; + register struct typemanager *tm; + register cl_object f; - ECL_NIL->symbol.m = FALSE; - ECL_T->symbol.m = FALSE; + ECL_NIL->symbol.m = FALSE; + ECL_T->symbol.m = FALSE; - if (debug) - printf("type map\n"); + if (debug) + printf("type map\n"); - for (i = 0; i < maxpage; i++) { - if (type_map[i] == (int)t_contiguous) { - if (debug) { - printf("-"); - continue; - } - } - if (type_map[i] >= (int)t_end) - continue; + for (i = 0; i < maxpage; i++) { + if (type_map[i] == (int)t_contiguous) { + if (debug) { + printf("-"); + continue; + } + } + if (type_map[i] >= (int)t_end) + continue; - tm = tm_of((cl_type)type_map[i]); + tm = tm_of((cl_type)type_map[i]); - /* - general sweeper - */ + /* + general sweeper + */ - if (debug) - printf("%c", tm->tm_name[0]); + if (debug) + printf("%c", tm->tm_name[0]); - p = pagetochar(i); - f = tm->tm_free; - k = 0; - for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { - x = (cl_object)p; - if (x->d.m == FREE) - continue; - else if (x->d.m) { - x->d.m = FALSE; - continue; - } - /* INV: Make sure this is the same as in alloc_2.d */ - switch (x->d.t) { + p = pagetochar(i); + f = tm->tm_free; + k = 0; + for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { + x = (cl_object)p; + if (x->d.m == FREE) + continue; + else if (x->d.m) { + x->d.m = FALSE; + continue; + } + /* INV: Make sure this is the same as in alloc_2.d */ + switch (x->d.t) { #ifdef ENABLE_DLOPEN - case t_codeblock: - ecl_library_close(x); - break; + case t_codeblock: + ecl_library_close(x); + break; #endif - case t_stream: + case t_stream: if (!x->stream.closed) - cl_close(1, x); + cl_close(1, x); break; #ifdef ECL_THREADS - case t_lock: + case t_lock: #if defined(ECL_MS_WINDOWS_HOST) - CloseHandle(x->lock.mutex); + CloseHandle(x->lock.mutex); #else - pthread_mutex_destroy(&x->lock.mutex); + pthread_mutex_destroy(&x->lock.mutex); #endif - break; - case t_condition_variable: + break; + case t_condition_variable: #if defined(ECL_MS_WINDOWS_HOST) - CloseHandle(x->condition_variable.cv); + CloseHandle(x->condition_variable.cv); #else - pthread_cond_destroy(&x->condition_variable.cv); + pthread_cond_destroy(&x->condition_variable.cv); #endif - break; + break; #endif #ifdef ECL_SEMAPHORES - case t_semaphore: + case t_semaphore: #error "Unfinished" - break; + break; #endif - default:; - } - ((struct freelist *)x)->f_link = f; - x->d.m = FREE; - f = x; - k++; - } - tm->tm_free = f; - tm->tm_nfree += k; - tm->tm_nused -= k; - } + default:; + } + ((struct freelist *)x)->f_link = f; + x->d.m = FREE; + f = x; + k++; + } + tm->tm_free = f; + tm->tm_nfree += k; + tm->tm_nused -= k; + } - if (debug) { - putchar('\n'); - fflush(stdout); - } + if (debug) { + putchar('\n'); + fflush(stdout); + } } static void contblock_sweep_phase(void) { - register int i, j; - register cl_ptr s, e, p, q; - register struct contblock *cbp; + register int i, j; + register cl_ptr s, e, p, q; + register struct contblock *cbp; - cb_pointer = NULL; - ncb = 0; - for (i = 0; i < maxpage;) { - if (type_map[i] != (int)t_contiguous) { - i++; - continue; - } - for (j = i+1; - j < maxpage && type_map[j] == (int)t_contiguous; - j++) - ; - s = pagetochar(i); - e = pagetochar(j); - for (p = s; p < e;) { - if (get_mark_bit((int *)p)) { - p += 4; - continue; - } - q = p + 4; - while (q < e && !get_mark_bit((int *)q)) - q += 4; - ecl_dealloc(p); - p = q + 4; - } - i = j + 1; - } + cb_pointer = NULL; + ncb = 0; + for (i = 0; i < maxpage;) { + if (type_map[i] != (int)t_contiguous) { + i++; + continue; + } + for (j = i+1; + j < maxpage && type_map[j] == (int)t_contiguous; + j++) + ; + s = pagetochar(i); + e = pagetochar(j); + for (p = s; p < e;) { + if (get_mark_bit((int *)p)) { + p += 4; + continue; + } + q = p + 4; + while (q < e && !get_mark_bit((int *)q)) + q += 4; + ecl_dealloc(p); + p = q + 4; + } + i = j + 1; + } - if (debug) { - for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) - printf("0x%p %d\n", cbp, cbp->cb_size); - fflush(stdout); - } + if (debug) { + for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link) + printf("0x%p %d\n", cbp, cbp->cb_size); + fflush(stdout); + } } cl_object (*GC_enter_hook)() = NULL; @@ -742,146 +742,146 @@ cl_object (*GC_exit_hook)() = NULL; void ecl_gc(cl_type t) { - const cl_env_ptr env = ecl_process_env(); - int i, j; - int tm; - int gc_start = ecl_runtime(); - bool interrupts; + const cl_env_ptr env = ecl_process_env(); + int i, j; + int tm; + int gc_start = ecl_runtime(); + bool interrupts; - if (!GC_enabled()) - return; + if (!GC_enabled()) + return; - GC_disable(); + GC_disable(); - CL_NEWENV_BEGIN { - if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { - printf("\n[GC .."); - /* To use this should add entries in tm_table for reloc and contig. - fprintf(stdout, "\n[GC for %d %s pages ..", - tm_of(t)->tm_npage, - tm_table[(int)t].tm_name + 1); */ - fflush(stdout); - } + CL_NEWENV_BEGIN { + if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { + printf("\n[GC .."); + /* To use this should add entries in tm_table for reloc and contig. + fprintf(stdout, "\n[GC for %d %s pages ..", + tm_of(t)->tm_npage, + tm_table[(int)t].tm_name + 1); */ + fflush(stdout); + } - debug = ecl_symbol_value(@'si::*gc-message*') != ECL_NIL; + debug = ecl_symbol_value(@'si::*gc-message*') != ECL_NIL; - if (GC_enter_hook != NULL) - (*GC_enter_hook)(); + if (GC_enter_hook != NULL) + (*GC_enter_hook)(); #ifdef THREADS #error "We need to stop all other threads" #endif /* THREADS */ - interrupts = env->disable_interrupts; - env->disable_interrupts = 1; + interrupts = env->disable_interrupts; + env->disable_interrupts = 1; - collect_blocks = t > t_end; - if (collect_blocks) - cbgccount++; - else - tm_table[(int)t].tm_gccount++; + collect_blocks = t > t_end; + if (collect_blocks) + cbgccount++; + else + tm_table[(int)t].tm_gccount++; - if (debug) { - if (collect_blocks) - printf("GC entered for collecting blocks\n"); - else - printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); - fflush(stdout); - } + if (debug) { + if (collect_blocks) + printf("GC entered for collecting blocks\n"); + else + printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); + fflush(stdout); + } - maxpage = page(heap_end); + maxpage = page(heap_end); - if (collect_blocks) { - /* - 1 page = 512 word - 512 bit = 16 word - */ - int mark_table_size = maxpage * (LISP_PAGESIZE / 32); - extern void cl_resize_hole(cl_index); + if (collect_blocks) { + /* + 1 page = 512 word + 512 bit = 16 word + */ + int mark_table_size = maxpage * (LISP_PAGESIZE / 32); + extern void cl_resize_hole(cl_index); - if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) - new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; - if (new_holepage < HOLEPAGE) - new_holepage = HOLEPAGE; - cl_resize_hole(new_holepage); + if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) + new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; + if (new_holepage < HOLEPAGE) + new_holepage = HOLEPAGE; + cl_resize_hole(new_holepage); - mark_table = (int*)heap_end; - for (i = 0; i < mark_table_size; i++) - mark_table[i] = 0; - } + mark_table = (int*)heap_end; + for (i = 0; i < mark_table_size; i++) + mark_table[i] = 0; + } - if (debug) { - printf("mark phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - mark_phase(); - if (debug) { - printf("mark ended (%d)\n", ecl_runtime() - tm); - printf("sweep phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - sweep_phase(); - if (debug) { - printf("sweep ended (%d)\n", ecl_runtime() - tm); - fflush(stdout); - } + if (debug) { + printf("mark phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + mark_phase(); + if (debug) { + printf("mark ended (%d)\n", ecl_runtime() - tm); + printf("sweep phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + sweep_phase(); + if (debug) { + printf("sweep ended (%d)\n", ecl_runtime() - tm); + fflush(stdout); + } - if (t == t_contiguous) { - if (debug) { - printf("contblock sweep phase\n"); - fflush(stdout); - tm = ecl_runtime(); - } - contblock_sweep_phase(); - if (debug) - printf("contblock sweep ended (%d)\n", ecl_runtime() - tm); - } + if (t == t_contiguous) { + if (debug) { + printf("contblock sweep phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + contblock_sweep_phase(); + if (debug) + printf("contblock sweep ended (%d)\n", ecl_runtime() - tm); + } - if (debug) { - for (i = 0, j = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (cl_type)i) { - printf("%13s: %8d used %8d free %4d/%d pages\n", - tm_table[i].tm_name, - tm_table[i].tm_nused, - tm_table[i].tm_nfree, - tm_table[i].tm_npage, - tm_table[i].tm_maxpage); - j += tm_table[i].tm_npage; - } else - printf("%13s: linked to %s\n", - tm_table[i].tm_name, - tm_table[(int)tm_table[i].tm_type].tm_name); - } - printf("contblock: %d blocks %d pages\n", ncb, ncbpage); - printf("hole: %d pages\n", holepage); - printf("GC ended\n"); - fflush(stdout); - } + if (debug) { + for (i = 0, j = 0; i < (int)t_end; i++) { + if (tm_table[i].tm_type == (cl_type)i) { + printf("%13s: %8d used %8d free %4d/%d pages\n", + tm_table[i].tm_name, + tm_table[i].tm_nused, + tm_table[i].tm_nfree, + tm_table[i].tm_npage, + tm_table[i].tm_maxpage); + j += tm_table[i].tm_npage; + } else + printf("%13s: linked to %s\n", + tm_table[i].tm_name, + tm_table[(int)tm_table[i].tm_type].tm_name); + } + printf("contblock: %d blocks %d pages\n", ncb, ncbpage); + printf("hole: %d pages\n", holepage); + printf("GC ended\n"); + fflush(stdout); + } - env->disable_interrupts = interrupts; + env->disable_interrupts = interrupts; - if (GC_exit_hook != NULL) - (*GC_exit_hook)(); + if (GC_exit_hook != NULL) + (*GC_exit_hook)(); - } CL_NEWENV_END; + } CL_NEWENV_END; - GC_enable(); + GC_enable(); #ifdef THREADS #error "We need to activate all other threads again" #endif /* THREADS */ - gc_time += (gc_start = ecl_runtime() - gc_start); + gc_time += (gc_start = ecl_runtime() - gc_start); - if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { - /* Don't use fprintf since on Linux it calls malloc() */ - printf(". finished in %.2f\"]", gc_start/60.0); - fflush(stdout); - } + if (SYM_VAL(@'si::*gc-verbose*') != ECL_NIL) { + /* Don't use fprintf since on Linux it calls malloc() */ + printf(". finished in %.2f\"]", gc_start/60.0); + fflush(stdout); + } - if (env->interrupt_pending) ecl_check_pending_interrupts(); + if (env->interrupt_pending) ecl_check_pending_interrupts(); } /* @@ -892,10 +892,10 @@ ecl_gc(cl_type t) * Both p and p+s are rounded to word boundaries. * * Results: - * none. + * none. * * Side effects: - * mark_table + * mark_table * *---------------------------------------------------------------------- */ @@ -903,17 +903,17 @@ ecl_gc(cl_type t) static void _mark_contblock(void *x, cl_index s) { - cl_ptr p = x; - if (p >= heap_start && p < data_end) { - ptrdiff_t pg = page(p); - if ((cl_type)type_map[pg] == t_contiguous) { - cl_ptr q = p + s; - p = int2ptr(ptr2int(p) & ~3); - q = int2ptr(ptr2int(q + 3) & ~3); - for (; p < q; p+= 4) - set_mark_bit(p); - } - } + cl_ptr p = x; + if (p >= heap_start && p < data_end) { + ptrdiff_t pg = page(p); + if ((cl_type)type_map[pg] == t_contiguous) { + cl_ptr q = p + s; + p = int2ptr(ptr2int(p) & ~3); + q = int2ptr(ptr2int(q + 3) & ~3); + for (; p < q; p+= 4) + set_mark_bit(p); + } + } } /*---------------------------------------------------------------------- @@ -922,66 +922,66 @@ _mark_contblock(void *x, cl_index s) */ @(defun si::room-report () - int i; - cl_object *tl; + int i; + cl_object *tl; @ - the_env->nvalues = 8; - the_env->values[0] = ecl_make_fixnum(real_maxpage); - the_env->values[1] = ecl_make_fixnum(available_pages()); - the_env->values[2] = ecl_make_fixnum(ncbpage); - the_env->values[3] = ecl_make_fixnum(maxcbpage); - the_env->values[4] = ecl_make_fixnum(ncb); - the_env->values[5] = ecl_make_fixnum(cbgccount); - the_env->values[6] = ecl_make_fixnum(holepage); - the_env->values[7] = ECL_NIL; - tl = &the_env->values[7]; - for (i = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (cl_type)i) { - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); - } else { - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); - } - } - return the_env->values[0]; + the_env->nvalues = 8; + the_env->values[0] = ecl_make_fixnum(real_maxpage); + the_env->values[1] = ecl_make_fixnum(available_pages()); + the_env->values[2] = ecl_make_fixnum(ncbpage); + the_env->values[3] = ecl_make_fixnum(maxcbpage); + the_env->values[4] = ecl_make_fixnum(ncb); + the_env->values[5] = ecl_make_fixnum(cbgccount); + the_env->values[6] = ecl_make_fixnum(holepage); + the_env->values[7] = ECL_NIL; + tl = &the_env->values[7]; + for (i = 0; i < (int)t_end; i++) { + if (tm_table[i].tm_type == (cl_type)i) { + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL)); + } else { + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL)); + } + } + return the_env->values[0]; @) @(defun si::reset-gc-count () - int i; + int i; @ - cbgccount = 0; - for (i = 0; i < (int)t_end; i++) - tm_table[i].tm_gccount = 0; - @(return) + cbgccount = 0; + for (i = 0; i < (int)t_end; i++) + tm_table[i].tm_gccount = 0; + @(return) @) @(defun si::gc-time () @ - @(return ecl_make_fixnum(gc_time)) + @(return ecl_make_fixnum(gc_time)) @) cl_object si_get_finalizer(cl_object o) { - @(return ECL_NIL) + @(return ECL_NIL) } cl_object si_set_finalizer(cl_object o, cl_object finalizer) { - @(return) + @(return) } void init_GC(void) { - GC_enable(); - gc_time = 0; + GC_enable(); + gc_time = 0; } diff --git a/src/c/gfun.d b/src/c/gfun.d index 140fc72c8..0403110f8 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -41,10 +41,10 @@ user_function_dispatch(cl_narg narg, ...) { int i; cl_object output; - cl_env_ptr env = ecl_process_env(); - cl_object fun = env->function; - struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); + cl_env_ptr env = ecl_process_env(); + cl_object fun = env->function; + struct ecl_stack_frame frame_aux; + const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg); ecl_va_list args; ecl_va_start(args, narg, narg, 0); for (i = 0; i < narg; i++) { ECL_STACK_FRAME_SET(frame, i, ecl_va_arg(args)); @@ -58,77 +58,77 @@ user_function_dispatch(cl_narg narg, ...) static void reshape_instance(cl_object x, int delta) { - cl_fixnum size = x->instance.length + delta; - cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size); + cl_fixnum size = x->instance.length + delta; + cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size); /* Except for the different size, this must match si_copy_instance */ aux->instance.sig = x->instance.sig; - memcpy(aux->instance.slots, x->instance.slots, - (delta < 0 ? aux->instance.length : x->instance.length) * - sizeof(cl_object)); - x->instance = aux->instance; + memcpy(aux->instance.slots, x->instance.slots, + (delta < 0 ? aux->instance.length : x->instance.length) * + sizeof(cl_object)); + x->instance = aux->instance; } cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[clos::set-funcallable-instance-function], 1, x, @[ext::instance]); - if (x->instance.isgf == ECL_USER_DISPATCH) { - reshape_instance(x, -1); - x->instance.isgf = ECL_NOT_FUNCALLABLE; - } - if (function_or_t == ECL_T) { - x->instance.isgf = ECL_STANDARD_DISPATCH; + if (x->instance.isgf == ECL_USER_DISPATCH) { + reshape_instance(x, -1); + x->instance.isgf = ECL_NOT_FUNCALLABLE; + } + if (function_or_t == ECL_T) { + x->instance.isgf = ECL_STANDARD_DISPATCH; x->instance.entry = generic_function_dispatch_vararg; - } else if (function_or_t == @'standard-generic-function') { - x->instance.isgf = ECL_RESTRICTED_DISPATCH; + } else if (function_or_t == @'standard-generic-function') { + x->instance.isgf = ECL_RESTRICTED_DISPATCH; x->instance.entry = generic_function_dispatch_vararg; - } else if (function_or_t == ECL_NIL) { - x->instance.isgf = ECL_NOT_FUNCALLABLE; + } else if (function_or_t == ECL_NIL) { + x->instance.isgf = ECL_NOT_FUNCALLABLE; x->instance.entry = FEnot_funcallable_vararg; - } else if (function_or_t == @'clos::standard-optimized-reader-method') { - /* WARNING: We assume that f(a,...) behaves as f(a,b) */ - x->instance.isgf = ECL_READER_DISPATCH; - x->instance.entry = (cl_objectfn)ecl_slot_reader_dispatch; - } else if (function_or_t == @'clos::standard-optimized-writer-method') { - /* WARNING: We assume that f(a,...) behaves as f(a,b) */ - x->instance.isgf = ECL_WRITER_DISPATCH; - x->instance.entry = (cl_objectfn)ecl_slot_writer_dispatch; - } else if (Null(cl_functionp(function_or_t))) { - FEwrong_type_argument(@'function', function_or_t); - } else { - reshape_instance(x, +1); - x->instance.slots[x->instance.length - 1] = function_or_t; - x->instance.isgf = ECL_USER_DISPATCH; + } else if (function_or_t == @'clos::standard-optimized-reader-method') { + /* WARNING: We assume that f(a,...) behaves as f(a,b) */ + x->instance.isgf = ECL_READER_DISPATCH; + x->instance.entry = (cl_objectfn)ecl_slot_reader_dispatch; + } else if (function_or_t == @'clos::standard-optimized-writer-method') { + /* WARNING: We assume that f(a,...) behaves as f(a,b) */ + x->instance.isgf = ECL_WRITER_DISPATCH; + x->instance.entry = (cl_objectfn)ecl_slot_writer_dispatch; + } else if (Null(cl_functionp(function_or_t))) { + FEwrong_type_argument(@'function', function_or_t); + } else { + reshape_instance(x, +1); + x->instance.slots[x->instance.length - 1] = function_or_t; + x->instance.isgf = ECL_USER_DISPATCH; x->instance.entry = user_function_dispatch; - } - @(return x) + } + @(return x) } cl_object si_generic_function_p(cl_object x) { - @(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? ECL_T : ECL_NIL)) + @(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? ECL_T : ECL_NIL)) } static cl_object fill_spec_vector(cl_object vector, cl_object frame, cl_object gf) { - cl_object *args = frame->frame.base; - cl_index narg = frame->frame.size; - cl_object spec_how_list = GFUN_SPEC(gf); - cl_object *argtype = vector->vector.self.t; - int spec_no = 1; - argtype[0] = gf; - loop_for_on_unsafe(spec_how_list) { - cl_object spec_how = ECL_CONS_CAR(spec_how_list); - cl_object spec_type = ECL_CONS_CAR(spec_how); - int spec_position = ecl_fixnum(ECL_CONS_CDR(spec_how)); - unlikely_if (spec_position >= narg) - FEwrong_num_arguments(gf); - unlikely_if (spec_no >= vector->vector.dim) - ecl_internal_error("Too many arguments to fill_spec_vector()"); + cl_object *args = frame->frame.base; + cl_index narg = frame->frame.size; + cl_object spec_how_list = GFUN_SPEC(gf); + cl_object *argtype = vector->vector.self.t; + int spec_no = 1; + argtype[0] = gf; + loop_for_on_unsafe(spec_how_list) { + cl_object spec_how = ECL_CONS_CAR(spec_how_list); + cl_object spec_type = ECL_CONS_CAR(spec_how); + int spec_position = ecl_fixnum(ECL_CONS_CDR(spec_how)); + unlikely_if (spec_position >= narg) + FEwrong_num_arguments(gf); + unlikely_if (spec_no >= vector->vector.dim) + ecl_internal_error("Too many arguments to fill_spec_vector()"); /* Need to differentiate between EQL specializers and class specializers, because the EQL value can be a class, and may classh with a class specializer. */ @@ -140,129 +140,129 @@ fill_spec_vector(cl_object vector, cl_object frame, cl_object gf) argtype[spec_no++] = 0; } - } end_loop_for_on_unsafe(spec_how_list); - vector->vector.fillp = spec_no; - return vector; + } end_loop_for_on_unsafe(spec_how_list); + vector->vector.fillp = spec_no; + return vector; } static cl_object frame_to_list(cl_object frame) { - cl_object arglist, *p; - for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; + cl_object arglist, *p; + for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; p != frame->frame.base; ) { - arglist = CONS(*(--p), arglist); - } - return arglist; + arglist = CONS(*(--p), arglist); + } + return arglist; } static cl_object frame_to_classes(cl_object frame) { - cl_object arglist, *p; - for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; + cl_object arglist, *p; + for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL; p != frame->frame.base; ) { - arglist = CONS(cl_class_of(*(--p)), arglist); - } - return arglist; + arglist = CONS(cl_class_of(*(--p)), arglist); + } + return arglist; } static cl_object generic_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - /* method not cached */ - cl_object memoize; - cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes', - gf, frame_to_classes(frame)); - unlikely_if (Null(memoize = env->values[1])) { - cl_object arglist = frame_to_list(frame); - methods = _ecl_funcall3(@'compute-applicable-methods', - gf, arglist); - unlikely_if (methods == ECL_NIL) { + /* method not cached */ + cl_object memoize; + cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes', + gf, frame_to_classes(frame)); + unlikely_if (Null(memoize = env->values[1])) { + cl_object arglist = frame_to_list(frame); + methods = _ecl_funcall3(@'compute-applicable-methods', + gf, arglist); + unlikely_if (methods == ECL_NIL) { env->values[1] = ECL_NIL; return methods; - } - } - methods = clos_compute_effective_method_function(gf, GFUN_COMB(gf), methods); - env->values[1] = ECL_T; - return methods; + } + } + methods = clos_compute_effective_method_function(gf, GFUN_COMB(gf), methods); + env->values[1] = ECL_T; + return methods; } static cl_object restricted_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - /* method not cached */ - cl_object arglist = frame_to_list(frame); - cl_object methods = clos_std_compute_applicable_methods(gf, arglist); - unlikely_if (methods == ECL_NIL) { - env->values[1] = ECL_NIL; - return methods; - } - methods = clos_std_compute_effective_method(gf, GFUN_COMB(gf), methods); - env->values[1] = ECL_T; - return methods; + /* method not cached */ + cl_object arglist = frame_to_list(frame); + cl_object methods = clos_std_compute_applicable_methods(gf, arglist); + unlikely_if (methods == ECL_NIL) { + env->values[1] = ECL_NIL; + return methods; + } + methods = clos_std_compute_effective_method(gf, GFUN_COMB(gf), methods); + env->values[1] = ECL_T; + return methods; } static cl_object compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) { - if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH) - return restricted_compute_applicable_method(env, frame, gf); - else - return generic_compute_applicable_method(env, frame, gf); + if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH) + return restricted_compute_applicable_method(env, frame, gf); + else + return generic_compute_applicable_method(env, frame, gf); } cl_object _ecl_standard_dispatch(cl_object frame, cl_object gf) { - cl_object func, vector; + cl_object func, vector; const cl_env_ptr env = frame->frame.env; - ecl_cache_ptr cache = env->method_cache; - ecl_cache_record_ptr e; - /* - * We have to copy the frame because it might be stored in cl_env.values - * which will be wiped out by the next function call. However this only - * happens when we cannot reuse the values in the C stack. - */ + ecl_cache_ptr cache = env->method_cache; + ecl_cache_record_ptr e; + /* + * We have to copy the frame because it might be stored in cl_env.values + * which will be wiped out by the next function call. However this only + * happens when we cannot reuse the values in the C stack. + */ #if !defined(ECL_USE_VARARG_AS_POINTER) - struct ecl_stack_frame frame_aux; - if (frame->frame.stack == (void*)0x1) { + struct ecl_stack_frame frame_aux; + if (frame->frame.stack == (void*)0x1) { const cl_object new_frame = (cl_object)&frame_aux; ECL_STACK_FRAME_COPY(new_frame, frame); frame = new_frame; - } + } #endif - vector = fill_spec_vector(cache->keys, frame, gf); - e = ecl_search_cache(cache); - if (e->key != OBJNULL) { - func = e->value; - } else { - /* The keys and the cache may change while we - * compute the applicable methods. We must save - * the keys and recompute the cache location if - * it was filled. */ - func = compute_applicable_method(env, frame, gf); - if (env->values[1] != ECL_NIL) { - cl_object keys = cl_copy_seq(vector); - if (e->key != OBJNULL) { - e = ecl_search_cache(cache); - } - e->key = keys; - e->value = func; - } - } + vector = fill_spec_vector(cache->keys, frame, gf); + e = ecl_search_cache(cache); + if (e->key != OBJNULL) { + func = e->value; + } else { + /* The keys and the cache may change while we + * compute the applicable methods. We must save + * the keys and recompute the cache location if + * it was filled. */ + func = compute_applicable_method(env, frame, gf); + if (env->values[1] != ECL_NIL) { + cl_object keys = cl_copy_seq(vector); + if (e->key != OBJNULL) { + e = ecl_search_cache(cache); + } + e->key = keys; + e->value = func; + } + } if (func == ECL_NIL) func = cl_apply(3, @'no-applicable-method', gf, frame); else func = _ecl_funcall3(func, frame, ECL_NIL); - /* Only need to close the copy */ + /* Only need to close the copy */ #if !defined(ECL_USE_VARARG_AS_POINTER) - if (frame == (cl_object)&frame_aux) - ecl_stack_frame_close(frame); + if (frame == (cl_object)&frame_aux) + ecl_stack_frame_close(frame); #endif - return func; + return func; } static cl_object @@ -270,8 +270,8 @@ generic_function_dispatch_vararg(cl_narg narg, ...) { cl_object output; ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { - output = _ecl_standard_dispatch(frame, frame->frame.env->function); - } ECL_STACK_FRAME_VARARGS_END(frame); + output = _ecl_standard_dispatch(frame, frame->frame.env->function); + } ECL_STACK_FRAME_VARARGS_END(frame); return output; } @@ -279,26 +279,26 @@ generic_function_dispatch_vararg(cl_narg narg, ...) cl_object si_clear_gfun_hash(cl_object what) { - /* - * This function clears the generic function call hashes selectively. - * what = ECL_T means clear the hash completely - * what = generic function, means cleans only these entries - * If we work on a multithreaded environment, we simply enqueue these - * operations and wait for the destination thread to update its own hash. - */ - cl_env_ptr the_env = ecl_process_env(); + /* + * This function clears the generic function call hashes selectively. + * what = ECL_T means clear the hash completely + * what = generic function, means cleans only these entries + * If we work on a multithreaded environment, we simply enqueue these + * operations and wait for the destination thread to update its own hash. + */ + cl_env_ptr the_env = ecl_process_env(); #ifdef ECL_THREADS - cl_object list; - for (list = mp_all_processes(); !Null(list); list = ECL_CONS_CDR(list)) { - cl_object process = ECL_CONS_CAR(list); - struct cl_env_struct *env = process->process.env; - if (the_env != env) { - ecl_cache_remove_one(env->method_cache, what); - ecl_cache_remove_one(env->slot_cache, what); - } - } + cl_object list; + for (list = mp_all_processes(); !Null(list); list = ECL_CONS_CDR(list)) { + cl_object process = ECL_CONS_CAR(list); + struct cl_env_struct *env = process->process.env; + if (the_env != env) { + ecl_cache_remove_one(env->method_cache, what); + ecl_cache_remove_one(env->slot_cache, what); + } + } #endif - ecl_cache_remove_one(the_env->method_cache, what); - ecl_cache_remove_one(the_env->slot_cache, what); + ecl_cache_remove_one(the_env->method_cache, what); + ecl_cache_remove_one(the_env->slot_cache, what); ecl_return0(the_env); } diff --git a/src/c/hash.d b/src/c/hash.d index 88b842747..7d9069b61 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -30,232 +30,232 @@ static void ECL_INLINE assert_type_hash_table(cl_object function, cl_narg narg, cl_object p) { - unlikely_if (!ECL_HASH_TABLE_P(p)) - FEwrong_type_nth_arg(function, narg, p, @[hash-table]); + unlikely_if (!ECL_HASH_TABLE_P(p)) + FEwrong_type_nth_arg(function, narg, p, @[hash-table]); } static cl_hashkey _hash_eql(cl_hashkey h, cl_object x) { - switch (ecl_t_of(x)) { - case t_bignum: - return hash_string(h, (unsigned char*)ECL_BIGNUM_LIMBS(x), - labs(ECL_BIGNUM_SIZE(x)) * - sizeof(mp_limb_t)); - case t_ratio: - h = _hash_eql(h, x->ratio.num); - return _hash_eql(h, x->ratio.den); - case t_singlefloat: - return hash_string(h, (unsigned char*)&ecl_single_float(x), sizeof(ecl_single_float(x))); - case t_doublefloat: - return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x))); + switch (ecl_t_of(x)) { + case t_bignum: + return hash_string(h, (unsigned char*)ECL_BIGNUM_LIMBS(x), + labs(ECL_BIGNUM_SIZE(x)) * + sizeof(mp_limb_t)); + case t_ratio: + h = _hash_eql(h, x->ratio.num); + return _hash_eql(h, x->ratio.den); + case t_singlefloat: + return hash_string(h, (unsigned char*)&ecl_single_float(x), sizeof(ecl_single_float(x))); + case t_doublefloat: + return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x))); #ifdef ECL_LONG_FLOAT - case t_longfloat: { + case t_longfloat: { /* We coerce to double because long double has extra bits * that give rise to different hash key and are not * meaningful */ struct { double mantissa; int exponent; int sign; } aux; aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); aux.sign = (ecl_long_float(x) < 0)? -1: 1; - return hash_string(h, (unsigned char*)&aux, sizeof(aux)); - } + return hash_string(h, (unsigned char*)&aux, sizeof(aux)); + } #endif - case t_complex: - h = _hash_eql(h, x->complex.real); - return _hash_eql(h, x->complex.imag); - case t_character: - return hash_word(h, ECL_CHAR_CODE(x)); + case t_complex: + h = _hash_eql(h, x->complex.real); + return _hash_eql(h, x->complex.imag); + case t_character: + return hash_word(h, ECL_CHAR_CODE(x)); #ifdef ECL_SSE2 - case t_sse_pack: - return hash_string(h, x->sse.data.b8, 16); + case t_sse_pack: + return hash_string(h, x->sse.data.b8, 16); #endif - default: - return hash_word(h, ((cl_hashkey)x >> 2)); - } + default: + return hash_word(h, ((cl_hashkey)x >> 2)); + } } static cl_hashkey _hash_equal(int depth, cl_hashkey h, cl_object x) { - switch (ecl_t_of(x)) { - case t_list: - if (Null(x)) { - return _hash_equal(depth, h, ECL_NIL_SYMBOL->symbol.name); - } - if (--depth == 0) { - return h; - } else { - h = _hash_equal(depth, h, ECL_CONS_CAR(x)); - return _hash_equal(depth, h, ECL_CONS_CDR(x)); - } - case t_symbol: - x = x->symbol.name; + switch (ecl_t_of(x)) { + case t_list: + if (Null(x)) { + return _hash_equal(depth, h, ECL_NIL_SYMBOL->symbol.name); + } + if (--depth == 0) { + return h; + } else { + h = _hash_equal(depth, h, ECL_CONS_CAR(x)); + return _hash_equal(depth, h, ECL_CONS_CDR(x)); + } + case t_symbol: + x = x->symbol.name; #ifdef ECL_UNICODE - case t_base_string: - return hash_base_string((ecl_base_char *)x->base_string.self, - x->base_string.fillp, h); - case t_string: - return hash_full_string(x->string.self, x->string.fillp, h); + case t_base_string: + return hash_base_string((ecl_base_char *)x->base_string.self, + x->base_string.fillp, h); + case t_string: + return hash_full_string(x->string.self, x->string.fillp, h); #else - case t_base_string: - return hash_string(h, (ecl_base_char *)x->base_string.self, - x->base_string.fillp); + case t_base_string: + return hash_string(h, (ecl_base_char *)x->base_string.self, + x->base_string.fillp); #endif - case t_pathname: - h = _hash_equal(0, h, x->pathname.directory); - h = _hash_equal(0, h, x->pathname.name); - h = _hash_equal(0, h, x->pathname.type); - h = _hash_equal(0, h, x->pathname.host); - h = _hash_equal(0, h, x->pathname.device); - return _hash_equal(0, h, x->pathname.version); - case t_bitvector: - /* Notice that we may round out some bits. We must do this - * because the fill pointer may be set in the middle of a byte. - * If so, the extra bits _must_ _not_ take part in the hash, - * because otherwise two bit arrays which are EQUAL might - * have different hash keys. */ - return hash_string(h, x->vector.self.bc, x->vector.fillp / 8); - case t_random: - return _hash_equal(0, h, x->random.value); + case t_pathname: + h = _hash_equal(0, h, x->pathname.directory); + h = _hash_equal(0, h, x->pathname.name); + h = _hash_equal(0, h, x->pathname.type); + h = _hash_equal(0, h, x->pathname.host); + h = _hash_equal(0, h, x->pathname.device); + return _hash_equal(0, h, x->pathname.version); + case t_bitvector: + /* Notice that we may round out some bits. We must do this + * because the fill pointer may be set in the middle of a byte. + * If so, the extra bits _must_ _not_ take part in the hash, + * because otherwise two bit arrays which are EQUAL might + * have different hash keys. */ + return hash_string(h, x->vector.self.bc, x->vector.fillp / 8); + case t_random: + return _hash_equal(0, h, x->random.value); #ifdef ECL_SIGNED_ZERO - case t_singlefloat: { - float f = ecl_single_float(x); - if (f == 0.0) f = 0.0; - return hash_string(h, (unsigned char*)&f, sizeof(f)); - } - case t_doublefloat: { - double f = ecl_double_float(x); - if (f == 0.0) f = 0.0; - return hash_string(h, (unsigned char*)&f, sizeof(f)); - } + case t_singlefloat: { + float f = ecl_single_float(x); + if (f == 0.0) f = 0.0; + return hash_string(h, (unsigned char*)&f, sizeof(f)); + } + case t_doublefloat: { + double f = ecl_double_float(x); + if (f == 0.0) f = 0.0; + return hash_string(h, (unsigned char*)&f, sizeof(f)); + } # ifdef ECL_LONG_FLOAT - case t_longfloat: { + case t_longfloat: { /* We coerce to double because long double has extra bits * that give rise to different hash key and are not * meaningful */ struct { double mantissa; int exponent; int sign; } aux; aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent); aux.sign = (ecl_long_float(x) < 0)? -1: 1; - if (aux.mantissa == 0.0) aux.mantissa = 0.0; - return hash_string(h, (unsigned char*)&aux, sizeof(aux)); - } + if (aux.mantissa == 0.0) aux.mantissa = 0.0; + return hash_string(h, (unsigned char*)&aux, sizeof(aux)); + } # endif - case t_complex: { - h = _hash_equal(depth, h, x->complex.real); - return _hash_equal(depth, h, x->complex.imag); - } + case t_complex: { + h = _hash_equal(depth, h, x->complex.real); + return _hash_equal(depth, h, x->complex.imag); + } #endif - default: - return _hash_eql(h, x); - } + default: + return _hash_eql(h, x); + } } static cl_hashkey _hash_equalp(int depth, cl_hashkey h, cl_object x) { - cl_index i, len; - switch (ecl_t_of(x)) { - case t_character: - return hash_word(h, ecl_char_upcase(ECL_CHAR_CODE(x))); - case t_list: - if (Null(x)) { - return _hash_equalp(depth, h, ECL_NIL_SYMBOL->symbol.name); - } - if (--depth == 0) { - return h; - } else { - h = _hash_equalp(depth, h, ECL_CONS_CAR(x)); - return _hash_equalp(depth, h, ECL_CONS_CDR(x)); - } + cl_index i, len; + switch (ecl_t_of(x)) { + case t_character: + return hash_word(h, ecl_char_upcase(ECL_CHAR_CODE(x))); + case t_list: + if (Null(x)) { + return _hash_equalp(depth, h, ECL_NIL_SYMBOL->symbol.name); + } + if (--depth == 0) { + return h; + } else { + h = _hash_equalp(depth, h, ECL_CONS_CAR(x)); + return _hash_equalp(depth, h, ECL_CONS_CDR(x)); + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - len = x->vector.fillp; - goto SCAN; - case t_array: - len = x->vector.dim; - SCAN: if (--depth) { - for (i = 0; i < len; i++) { - h = _hash_equalp(depth, h, ecl_aref_unsafe(x, i)); - } - } - return h; - case t_fixnum: - return hash_word(h, ecl_fixnum(x)); - case t_singlefloat: - /* FIXME! We should be more precise here! */ - return hash_word(h, (cl_index)ecl_single_float(x)); - case t_doublefloat: - /* FIXME! We should be more precise here! */ - return hash_word(h, (cl_index)ecl_double_float(x)); - case t_bignum: - /* FIXME! We should be more precise here! */ - return hash_string(h, (unsigned char*)x->big.big_num->_mp_d, - abs(x->big.big_num->_mp_size) * - sizeof(mp_limb_t)); - case t_ratio: - h = _hash_equalp(0, h, x->ratio.num); - return _hash_equalp(0, h, x->ratio.den); - case t_complex: - h = _hash_equalp(0, h, x->complex.real); - return _hash_equalp(0, h, x->complex.imag); - case t_instance: - case t_hashtable: - /* FIXME! We should be more precise here! */ - return hash_word(h, 42); - default: - return _hash_equal(depth, h, x); - } + case t_base_string: + case t_vector: + case t_bitvector: + len = x->vector.fillp; + goto SCAN; + case t_array: + len = x->vector.dim; + SCAN: if (--depth) { + for (i = 0; i < len; i++) { + h = _hash_equalp(depth, h, ecl_aref_unsafe(x, i)); + } + } + return h; + case t_fixnum: + return hash_word(h, ecl_fixnum(x)); + case t_singlefloat: + /* FIXME! We should be more precise here! */ + return hash_word(h, (cl_index)ecl_single_float(x)); + case t_doublefloat: + /* FIXME! We should be more precise here! */ + return hash_word(h, (cl_index)ecl_double_float(x)); + case t_bignum: + /* FIXME! We should be more precise here! */ + return hash_string(h, (unsigned char*)x->big.big_num->_mp_d, + abs(x->big.big_num->_mp_size) * + sizeof(mp_limb_t)); + case t_ratio: + h = _hash_equalp(0, h, x->ratio.num); + return _hash_equalp(0, h, x->ratio.den); + case t_complex: + h = _hash_equalp(0, h, x->complex.real); + return _hash_equalp(0, h, x->complex.imag); + case t_instance: + case t_hashtable: + /* FIXME! We should be more precise here! */ + return hash_word(h, 42); + default: + return _hash_equal(depth, h, x); + } } #define HASH_TABLE_LOOP(hkey,hvalue,h,HASH_TABLE_LOOP_TEST) { \ - cl_index hsize = hashtable->hash.size; \ + cl_index hsize = hashtable->hash.size; \ cl_index i = h % hsize, j = hsize, k; \ - for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { \ - struct ecl_hashtable_entry *e = hashtable->hash.data + i; \ - cl_object hkey = e->key, hvalue = e->value; \ - if (hkey == OBJNULL) { \ - if (e->value == OBJNULL) { \ - if (j == hsize) \ - return e; \ - else \ - return hashtable->hash.data + j; \ - } else { \ - if (j == hsize) \ - j = i; \ - else if (j == i) \ + for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { \ + struct ecl_hashtable_entry *e = hashtable->hash.data + i; \ + cl_object hkey = e->key, hvalue = e->value; \ + if (hkey == OBJNULL) { \ + if (e->value == OBJNULL) { \ + if (j == hsize) \ + return e; \ + else \ + return hashtable->hash.data + j; \ + } else { \ + if (j == hsize) \ + j = i; \ + else if (j == i) \ return e; \ } \ - continue; \ - } \ - if (HASH_TABLE_LOOP_TEST) return hashtable->hash.data + i; \ - } \ - return hashtable->hash.data + j; \ + continue; \ + } \ + if (HASH_TABLE_LOOP_TEST) return hashtable->hash.data + i; \ + } \ + return hashtable->hash.data + j; \ } #if 0 #define HASH_TABLE_SET(h,loop,compute_key,store_key) #else -#define HASH_TABLE_SET(h,loop,compute_key,store_key) { \ - cl_hashkey h = compute_key; \ - struct ecl_hashtable_entry *e; \ - AGAIN: \ - e = loop(h, key, hashtable); \ - if (e->key == OBJNULL) { \ - cl_index i = hashtable->hash.entries + 1; \ - if (i >= hashtable->hash.limit) { \ - hashtable = ecl_extend_hashtable(hashtable); \ - goto AGAIN; \ - } \ - hashtable->hash.entries = i; \ - e->key = store_key; \ - } \ - e->value = value; \ - return hashtable; \ - } +#define HASH_TABLE_SET(h,loop,compute_key,store_key) { \ + cl_hashkey h = compute_key; \ + struct ecl_hashtable_entry *e; \ + AGAIN: \ + e = loop(h, key, hashtable); \ + if (e->key == OBJNULL) { \ + cl_index i = hashtable->hash.entries + 1; \ + if (i >= hashtable->hash.limit) { \ + hashtable = ecl_extend_hashtable(hashtable); \ + goto AGAIN; \ + } \ + hashtable->hash.entries = i; \ + e->key = store_key; \ + } \ + e->value = value; \ + return hashtable; \ + } #endif /* @@ -277,30 +277,30 @@ _ecl_hash_loop_eq(cl_hashkey h, cl_object key, cl_object hashtable) static cl_object _ecl_gethash_eq(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_eq(key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_eq(key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static bool _ecl_remhash_eq(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_eq(key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_eq(key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } static cl_object _ecl_sethash_eq(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_eq, _hash_eq(key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_eq, _hash_eq(key), key); } /* @@ -316,30 +316,30 @@ _ecl_hash_loop_eql(cl_hashkey h, cl_object key, cl_object hashtable) static cl_object _ecl_gethash_eql(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_eql(0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_eql(0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_eql(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_eql, _hash_eql(0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_eql, _hash_eql(0, key), key); } static bool _ecl_remhash_eql(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_eql(0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_eql(0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -355,30 +355,30 @@ _ecl_hash_loop_equal(cl_hashkey h, cl_object key, cl_object hashtable) static cl_object _ecl_gethash_equal(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_equal(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_equal, _hash_equal(3, 0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_equal, _hash_equal(3, 0, key), key); } static bool _ecl_remhash_equal(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -394,30 +394,30 @@ _ecl_hash_loop_equalp(cl_hashkey h, cl_object key, cl_object hashtable) static cl_object _ecl_gethash_equalp(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equalp(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equalp(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_equalp(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_equalp, _hash_equalp(3, 0, key), key); + HASH_TABLE_SET(h, _ecl_hash_loop_equalp, _hash_equalp(3, 0, key), key); } static bool _ecl_remhash_equalp(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equalp(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equalp(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -434,30 +434,30 @@ _ecl_hash_loop_pack(cl_hashkey h, cl_object key, cl_object hashtable) static cl_object _ecl_gethash_pack(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); - return (e->key == OBJNULL)? def : e->value; + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); + return (e->key == OBJNULL)? def : e->value; } static cl_object _ecl_sethash_pack(cl_object key, cl_object hashtable, cl_object value) { - HASH_TABLE_SET(h, _ecl_hash_loop_pack, _hash_equal(3, 0, key), ecl_make_fixnum(h & 0xFFFFFFF)); + HASH_TABLE_SET(h, _ecl_hash_loop_pack, _hash_equal(3, 0, key), ecl_make_fixnum(h & 0xFFFFFFF)); } static bool _ecl_remhash_pack(cl_object key, cl_object hashtable) { - cl_hashkey h = _hash_equal(3, 0, key); - struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); - if (e->key == OBJNULL) { - return 0; - } else { - e->key = OBJNULL; - e->value = ECL_NIL; - hashtable->hash.entries--; - return 1; - } + cl_hashkey h = _hash_equal(3, 0, key); + struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable); + if (e->key == OBJNULL) { + return 0; + } else { + e->key = OBJNULL; + e->value = ECL_NIL; + hashtable->hash.entries--; + return 1; + } } /* @@ -470,172 +470,172 @@ _ecl_remhash_pack(cl_object key, cl_object hashtable) #ifdef ECL_WEAK_HASH static cl_hashkey _ecl_hash_key(cl_object h, cl_object o) { - switch (h->hash.test) { - case ecl_htt_eq: return _hash_eq(o); - case ecl_htt_eql: return _hash_eql(0, o); - case ecl_htt_equal: return _hash_equal(3, 0, o); - case ecl_htt_equalp: - default: return _hash_equalp(3, 0, o); - } + switch (h->hash.test) { + case ecl_htt_eq: return _hash_eq(o); + case ecl_htt_eql: return _hash_eql(0, o); + case ecl_htt_equal: return _hash_equal(3, 0, o); + case ecl_htt_equalp: + default: return _hash_equalp(3, 0, o); + } } static void * normalize_weak_key_entry(struct ecl_hashtable_entry *e) { - return (void*)(e->key = e->key->weak.value); + return (void*)(e->key = e->key->weak.value); } static void * normalize_weak_value_entry(struct ecl_hashtable_entry *e) { - return (void*)(e->value = e->value->weak.value); + return (void*)(e->value = e->value->weak.value); } static void * normalize_weak_key_and_value_entry(struct ecl_hashtable_entry *e) { - if ((e->key = e->key->weak.value) && (e->value = e->value->weak.value)) - return (void*)e; - else - return 0; + if ((e->key = e->key->weak.value) && (e->value = e->value->weak.value)) + return (void*)e; + else + return 0; } static struct ecl_hashtable_entry copy_entry(struct ecl_hashtable_entry *e, cl_object h) { - if (e->key == OBJNULL) { - return *e; - } else { - struct ecl_hashtable_entry output = *e; - switch (h->hash.weak) { - case ecl_htt_weak_key: - if (GC_call_with_alloc_lock(normalize_weak_key_entry, - &output)) { - return output; - } - break; - case ecl_htt_weak_value: - if (GC_call_with_alloc_lock(normalize_weak_value_entry, - &output)) { - return output; - } - break; - case ecl_htt_weak_key_and_value: - if (GC_call_with_alloc_lock(normalize_weak_key_and_value_entry, - &output)) { - return output; - } - break; - case ecl_htt_not_weak: - default: - return output; - } - h->hash.entries--; - output.key = OBJNULL; - output.value = ECL_NIL; - return *e = output; - } + if (e->key == OBJNULL) { + return *e; + } else { + struct ecl_hashtable_entry output = *e; + switch (h->hash.weak) { + case ecl_htt_weak_key: + if (GC_call_with_alloc_lock(normalize_weak_key_entry, + &output)) { + return output; + } + break; + case ecl_htt_weak_value: + if (GC_call_with_alloc_lock(normalize_weak_value_entry, + &output)) { + return output; + } + break; + case ecl_htt_weak_key_and_value: + if (GC_call_with_alloc_lock(normalize_weak_key_and_value_entry, + &output)) { + return output; + } + break; + case ecl_htt_not_weak: + default: + return output; + } + h->hash.entries--; + output.key = OBJNULL; + output.value = ECL_NIL; + return *e = output; + } } static struct ecl_hashtable_entry * _ecl_weak_hash_loop(cl_hashkey h, cl_object key, cl_object hashtable, - struct ecl_hashtable_entry *aux) + struct ecl_hashtable_entry *aux) { - cl_index hsize = hashtable->hash.size; + cl_index hsize = hashtable->hash.size; cl_index i = h % hsize, j = hsize, k; - for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { - struct ecl_hashtable_entry *p = hashtable->hash.data + i; - struct ecl_hashtable_entry e = *aux = copy_entry(p, hashtable); - if (e.key == OBJNULL) { - if (e.value == OBJNULL) { - if (j == hsize) { - return p; - } else { - return hashtable->hash.data + j; - } - } else { - if (j == hsize) { - j = i; - } else if (j == i) { + for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { + struct ecl_hashtable_entry *p = hashtable->hash.data + i; + struct ecl_hashtable_entry e = *aux = copy_entry(p, hashtable); + if (e.key == OBJNULL) { + if (e.value == OBJNULL) { + if (j == hsize) { return p; - } + } else { + return hashtable->hash.data + j; + } + } else { + if (j == hsize) { + j = i; + } else if (j == i) { + return p; + } } - continue; - } - switch (hashtable->hash.test) { - case ecl_htt_eq: - if (e.key == key) return p; - case ecl_htt_eql: - if (ecl_eql(e.key, key)) return p; - case ecl_htt_equal: - if (ecl_equal(e.key, key)) return p; - case ecl_htt_equalp: - if (ecl_equalp(e.key, key)) return p; - } - } - return hashtable->hash.data + j; + continue; + } + switch (hashtable->hash.test) { + case ecl_htt_eq: + if (e.key == key) return p; + case ecl_htt_eql: + if (ecl_eql(e.key, key)) return p; + case ecl_htt_equal: + if (ecl_equal(e.key, key)) return p; + case ecl_htt_equalp: + if (ecl_equalp(e.key, key)) return p; + } + } + return hashtable->hash.data + j; } static cl_object _ecl_gethash_weak(cl_object key, cl_object hashtable, cl_object def) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key != OBJNULL) { - return aux->value; - } else { - return def; - } + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key != OBJNULL) { + return aux->value; + } else { + return def; + } } static cl_object _ecl_sethash_weak(cl_object key, cl_object hashtable, cl_object value) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - struct ecl_hashtable_entry *e; + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + struct ecl_hashtable_entry *e; AGAIN: - e = _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key == OBJNULL) { - cl_index i = hashtable->hash.entries + 1; - if (i >= hashtable->hash.limit) { - hashtable = ecl_extend_hashtable(hashtable); - goto AGAIN; - } - hashtable->hash.entries = i; - switch (hashtable->hash.weak) { - case ecl_htt_weak_key: - key = si_make_weak_pointer(key); - break; - case ecl_htt_weak_value: - value = si_make_weak_pointer(value); - break; - case ecl_htt_weak_key_and_value: - default: - key = si_make_weak_pointer(key); - value = si_make_weak_pointer(value); - break; - } - e->key = key; - } - e->value = value; - return hashtable; + e = _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key == OBJNULL) { + cl_index i = hashtable->hash.entries + 1; + if (i >= hashtable->hash.limit) { + hashtable = ecl_extend_hashtable(hashtable); + goto AGAIN; + } + hashtable->hash.entries = i; + switch (hashtable->hash.weak) { + case ecl_htt_weak_key: + key = si_make_weak_pointer(key); + break; + case ecl_htt_weak_value: + value = si_make_weak_pointer(value); + break; + case ecl_htt_weak_key_and_value: + default: + key = si_make_weak_pointer(key); + value = si_make_weak_pointer(value); + break; + } + e->key = key; + } + e->value = value; + return hashtable; } static bool _ecl_remhash_weak(cl_object key, cl_object hashtable) { - cl_hashkey h = _ecl_hash_key(hashtable, key); - struct ecl_hashtable_entry aux[1]; - struct ecl_hashtable_entry *e = - _ecl_weak_hash_loop(h, key, hashtable, aux); - if (aux->key != OBJNULL) { - hashtable->hash.entries--; - e->key = OBJNULL; - e->value = ECL_NIL; - return 1; - } else { - return 0; - } + cl_hashkey h = _ecl_hash_key(hashtable, key); + struct ecl_hashtable_entry aux[1]; + struct ecl_hashtable_entry *e = + _ecl_weak_hash_loop(h, key, hashtable, aux); + if (aux->key != OBJNULL) { + hashtable->hash.entries--; + e->key = OBJNULL; + e->value = ECL_NIL; + return 1; + } else { + return 0; + } } #endif @@ -647,56 +647,56 @@ _ecl_remhash_weak(cl_object key, cl_object hashtable) cl_object ecl_gethash(cl_object key, cl_object hashtable) { - assert_type_hash_table(@[gethash], 2, hashtable); - return hashtable->hash.get(key, hashtable, OBJNULL); + assert_type_hash_table(@[gethash], 2, hashtable); + return hashtable->hash.get(key, hashtable, OBJNULL); } cl_object ecl_gethash_safe(cl_object key, cl_object hashtable, cl_object def) { - assert_type_hash_table(@[gethash], 2, hashtable); - return hashtable->hash.get(key, hashtable, def); + assert_type_hash_table(@[gethash], 2, hashtable); + return hashtable->hash.get(key, hashtable, def); } cl_object _ecl_sethash(cl_object key, cl_object hashtable, cl_object value) { - return hashtable->hash.set(key, hashtable, value); + return hashtable->hash.set(key, hashtable, value); } cl_object ecl_sethash(cl_object key, cl_object hashtable, cl_object value) { - assert_type_hash_table(@[si::hash-set], 2, hashtable); - hashtable = hashtable->hash.set(key, hashtable, value); - return hashtable; + assert_type_hash_table(@[si::hash-set], 2, hashtable); + hashtable = hashtable->hash.set(key, hashtable, value); + return hashtable; } cl_object ecl_extend_hashtable(cl_object hashtable) { - cl_object old, new; - cl_index old_size, new_size, i; - cl_object new_size_obj; + cl_object old, new; + cl_index old_size, new_size, i; + cl_object new_size_obj; - assert_type_hash_table(@[si::hash-set], 2, hashtable); - old_size = hashtable->hash.size; - /* We do the computation with lisp datatypes, just in case the sizes contain - * weird numbers */ - if (ECL_FIXNUMP(hashtable->hash.rehash_size)) { - new_size_obj = ecl_plus(hashtable->hash.rehash_size, - ecl_make_fixnum(old_size)); - } else { - new_size_obj = ecl_times(hashtable->hash.rehash_size, - ecl_make_fixnum(old_size)); - new_size_obj = ecl_ceiling1(new_size_obj); - } - if (!ECL_FIXNUMP(new_size_obj)) { - /* New size is too large */ - new_size = old_size * 2; - } else { - new_size = ecl_fixnum(new_size_obj); - } + assert_type_hash_table(@[si::hash-set], 2, hashtable); + old_size = hashtable->hash.size; + /* We do the computation with lisp datatypes, just in case the sizes contain + * weird numbers */ + if (ECL_FIXNUMP(hashtable->hash.rehash_size)) { + new_size_obj = ecl_plus(hashtable->hash.rehash_size, + ecl_make_fixnum(old_size)); + } else { + new_size_obj = ecl_times(hashtable->hash.rehash_size, + ecl_make_fixnum(old_size)); + new_size_obj = ecl_ceiling1(new_size_obj); + } + if (!ECL_FIXNUMP(new_size_obj)) { + /* New size is too large */ + new_size = old_size * 2; + } else { + new_size = ecl_fixnum(new_size_obj); + } if (hashtable->hash.test == ecl_htt_pack) { new = ecl_alloc_object(t_hashtable); new->hash = hashtable->hash; @@ -706,121 +706,121 @@ ecl_extend_hashtable(cl_object hashtable) old->hash = hashtable->hash; new = hashtable; } - new->hash.data = NULL; /* for GC sake */ - new->hash.entries = 0; - new->hash.size = new_size; - new->hash.limit = new->hash.size * new->hash.factor; - new->hash.data = (struct ecl_hashtable_entry *) - ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); - for (i = 0; i < new_size; i++) { - new->hash.data[i].key = OBJNULL; - new->hash.data[i].value = OBJNULL; - } - for (i = 0; i < old_size; i++) { - struct ecl_hashtable_entry e = - copy_entry(old->hash.data + i, old); - if (e.key != OBJNULL) { - new = new->hash.set(new->hash.test == ecl_htt_pack? - SYMBOL_NAME(e.value) : e.key, - new, e.value); - } - } + new->hash.data = NULL; /* for GC sake */ + new->hash.entries = 0; + new->hash.size = new_size; + new->hash.limit = new->hash.size * new->hash.factor; + new->hash.data = (struct ecl_hashtable_entry *) + ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); + for (i = 0; i < new_size; i++) { + new->hash.data[i].key = OBJNULL; + new->hash.data[i].value = OBJNULL; + } + for (i = 0; i < old_size; i++) { + struct ecl_hashtable_entry e = + copy_entry(old->hash.data + i, old); + if (e.key != OBJNULL) { + new = new->hash.set(new->hash.test == ecl_htt_pack? + SYMBOL_NAME(e.value) : e.key, + new, e.value); + } + } return new; } @(defun make_hash_table (&key (test @'eql') - (weakness ECL_NIL) - (size ecl_make_fixnum(1024)) + (weakness ECL_NIL) + (size ecl_make_fixnum(1024)) (rehash_size cl_core.rehash_size) - (rehash_threshold cl_core.rehash_threshold)) + (rehash_threshold cl_core.rehash_threshold)) @ { - cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); + cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); #ifdef ECL_WEAK_HASH - if (!Null(weakness)) { - if (weakness == @':key') { - hash->hash.weak = ecl_htt_weak_key; - } else if (weakness == @':value') { - hash->hash.weak = ecl_htt_weak_value; - } else if (weakness == @':key-and-value') { - hash->hash.weak = ecl_htt_weak_key_and_value; - } else { - FEwrong_type_key_arg(@[make-hash-table], - @[:weakness], - cl_list(5, @'member', - ECL_NIL, @':key', @':value', - @':key-and-value'), - weakness); - } - hash->hash.get = _ecl_gethash_weak; - hash->hash.set = _ecl_sethash_weak; - hash->hash.rem = _ecl_remhash_weak; - } + if (!Null(weakness)) { + if (weakness == @':key') { + hash->hash.weak = ecl_htt_weak_key; + } else if (weakness == @':value') { + hash->hash.weak = ecl_htt_weak_value; + } else if (weakness == @':key-and-value') { + hash->hash.weak = ecl_htt_weak_key_and_value; + } else { + FEwrong_type_key_arg(@[make-hash-table], + @[:weakness], + cl_list(5, @'member', + ECL_NIL, @':key', @':value', + @':key-and-value'), + weakness); + } + hash->hash.get = _ecl_gethash_weak; + hash->hash.set = _ecl_sethash_weak; + hash->hash.rem = _ecl_remhash_weak; + } #endif - @(return hash) + @(return hash) } @) static void do_clrhash(cl_object ht) { - /* - * Fill a hash with null pointers and ensure it does not have - * any entry. We separate this routine because it is needed - * both by clrhash and hash table initialization. - */ - cl_index i; - ht->hash.entries = 0; - for(i = 0; i < ht->hash.size; i++) { - ht->hash.data[i].key = OBJNULL; - ht->hash.data[i].value = OBJNULL; - } + /* + * Fill a hash with null pointers and ensure it does not have + * any entry. We separate this routine because it is needed + * both by clrhash and hash table initialization. + */ + cl_index i; + ht->hash.entries = 0; + for(i = 0; i < ht->hash.size; i++) { + ht->hash.data[i].key = OBJNULL; + ht->hash.data[i].value = OBJNULL; + } } ecl_def_ct_single_float(min_threshold, 0.1, static, const); cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, - cl_object rehash_threshold) + cl_object rehash_threshold) { - int htt; - cl_index hsize; - cl_object h; - cl_object (*get)(cl_object, cl_object, cl_object); - cl_object (*set)(cl_object, cl_object, cl_object); - bool (*rem)(cl_object, cl_object); - /* - * Argument checking - */ - if (test == @'eq' || test == ECL_SYM_FUN(@'eq')) { - htt = ecl_htt_eq; - get = _ecl_gethash_eq; - set = _ecl_sethash_eq; - rem = _ecl_remhash_eq; - } else if (test == @'eql' || test == ECL_SYM_FUN(@'eql')) { - htt = ecl_htt_eql; - get = _ecl_gethash_eql; - set = _ecl_sethash_eql; - rem = _ecl_remhash_eql; - } else if (test == @'equal' || test == ECL_SYM_FUN(@'equal')) { - htt = ecl_htt_equal; - get = _ecl_gethash_equal; - set = _ecl_sethash_equal; - rem = _ecl_remhash_equal; - } else if (test == @'equalp' || test == ECL_SYM_FUN(@'equalp')) { - htt = ecl_htt_equalp; - get = _ecl_gethash_equalp; - set = _ecl_sethash_equalp; - rem = _ecl_remhash_equalp; - } else if (test == @'package') { - htt = ecl_htt_pack; - get = _ecl_gethash_pack; - set = _ecl_sethash_pack; - rem = _ecl_remhash_pack; - } else { - FEerror("~S is an illegal hash-table test function.", - 1, test); - } + int htt; + cl_index hsize; + cl_object h; + cl_object (*get)(cl_object, cl_object, cl_object); + cl_object (*set)(cl_object, cl_object, cl_object); + bool (*rem)(cl_object, cl_object); + /* + * Argument checking + */ + if (test == @'eq' || test == ECL_SYM_FUN(@'eq')) { + htt = ecl_htt_eq; + get = _ecl_gethash_eq; + set = _ecl_sethash_eq; + rem = _ecl_remhash_eq; + } else if (test == @'eql' || test == ECL_SYM_FUN(@'eql')) { + htt = ecl_htt_eql; + get = _ecl_gethash_eql; + set = _ecl_sethash_eql; + rem = _ecl_remhash_eql; + } else if (test == @'equal' || test == ECL_SYM_FUN(@'equal')) { + htt = ecl_htt_equal; + get = _ecl_gethash_equal; + set = _ecl_sethash_equal; + rem = _ecl_remhash_equal; + } else if (test == @'equalp' || test == ECL_SYM_FUN(@'equalp')) { + htt = ecl_htt_equalp; + get = _ecl_gethash_equalp; + set = _ecl_sethash_equalp; + rem = _ecl_remhash_equalp; + } else if (test == @'package') { + htt = ecl_htt_pack; + get = _ecl_gethash_pack; + set = _ecl_sethash_pack; + rem = _ecl_remhash_pack; + } else { + FEerror("~S is an illegal hash-table test function.", + 1, test); + } if (ecl_unlikely(!ECL_FIXNUMP(size) || ecl_fixnum_minusp(size) || ecl_fixnum_geq(size,ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)))) { @@ -829,210 +829,210 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT))); } hsize = ecl_fixnum(size); - if (hsize < 16) { - hsize = 16; - } + if (hsize < 16) { + hsize = 16; + } AGAIN: - if (ecl_minusp(rehash_size)) { - ERROR1: - rehash_size = - ecl_type_error(@'make-hash-table',"rehash-size", - rehash_size, - ecl_read_from_cstring("(OR (INTEGER 1 *) (FLOAT 0 (1)))")); - goto AGAIN; - } - if (floatp(rehash_size)) { - if (ecl_number_compare(rehash_size, ecl_make_fixnum(1)) < 0 || - ecl_minusp(rehash_size)) { - goto ERROR1; - } - rehash_size = ecl_make_double_float(ecl_to_double(rehash_size)); - } else if (!ECL_FIXNUMP(rehash_size)) { - goto ERROR1; - } - while (!ecl_numberp(rehash_threshold) || - ecl_minusp(rehash_threshold) || - ecl_number_compare(rehash_threshold, ecl_make_fixnum(1)) > 0) - { - rehash_threshold = - ecl_type_error(@'make-hash-table',"rehash-threshold", - rehash_threshold, - ecl_read_from_cstring("(REAL 0 1)")); - } - /* - * Build actual hash. - */ - h = ecl_alloc_object(t_hashtable); - h->hash.test = htt; - h->hash.weak = ecl_htt_not_weak; - h->hash.get = get; - h->hash.set = set; - h->hash.rem = rem; - h->hash.size = hsize; + if (ecl_minusp(rehash_size)) { + ERROR1: + rehash_size = + ecl_type_error(@'make-hash-table',"rehash-size", + rehash_size, + ecl_read_from_cstring("(OR (INTEGER 1 *) (FLOAT 0 (1)))")); + goto AGAIN; + } + if (floatp(rehash_size)) { + if (ecl_number_compare(rehash_size, ecl_make_fixnum(1)) < 0 || + ecl_minusp(rehash_size)) { + goto ERROR1; + } + rehash_size = ecl_make_double_float(ecl_to_double(rehash_size)); + } else if (!ECL_FIXNUMP(rehash_size)) { + goto ERROR1; + } + while (!ecl_numberp(rehash_threshold) || + ecl_minusp(rehash_threshold) || + ecl_number_compare(rehash_threshold, ecl_make_fixnum(1)) > 0) + { + rehash_threshold = + ecl_type_error(@'make-hash-table',"rehash-threshold", + rehash_threshold, + ecl_read_from_cstring("(REAL 0 1)")); + } + /* + * Build actual hash. + */ + h = ecl_alloc_object(t_hashtable); + h->hash.test = htt; + h->hash.weak = ecl_htt_not_weak; + h->hash.get = get; + h->hash.set = set; + h->hash.rem = rem; + h->hash.size = hsize; h->hash.entries = 0; - h->hash.rehash_size = rehash_size; - h->hash.threshold = rehash_threshold; + h->hash.rehash_size = rehash_size; + h->hash.threshold = rehash_threshold; rehash_threshold = cl_max(2, min_threshold, rehash_threshold); - h->hash.factor = ecl_to_double(rehash_threshold); - h->hash.limit = h->hash.size * h->hash.factor; - h->hash.data = NULL; /* for GC sake */ - h->hash.data = (struct ecl_hashtable_entry *) - ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); - do_clrhash(h); - return h; + h->hash.factor = ecl_to_double(rehash_threshold); + h->hash.limit = h->hash.size * h->hash.factor; + h->hash.data = NULL; /* for GC sake */ + h->hash.data = (struct ecl_hashtable_entry *) + ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); + do_clrhash(h); + return h; } cl_object cl_hash_table_p(cl_object ht) { - @(return (ECL_HASH_TABLE_P(ht) ? ECL_T : ECL_NIL)) + @(return (ECL_HASH_TABLE_P(ht) ? ECL_T : ECL_NIL)) } cl_object si_hash_table_weakness(cl_object ht) { - cl_object output = ECL_NIL; + cl_object output = ECL_NIL; #ifdef ECL_WEAK_HASH - switch (ht->hash.weak) { - case ecl_htt_weak_key: output = @':key'; break; - case ecl_htt_weak_value: output = @':value'; break; - case ecl_htt_weak_key_and_value: output = @':key-and-value'; break; - case ecl_htt_not_weak: default: output = ECL_NIL; break; - } + switch (ht->hash.weak) { + case ecl_htt_weak_key: output = @':key'; break; + case ecl_htt_weak_value: output = @':value'; break; + case ecl_htt_weak_key_and_value: output = @':key-and-value'; break; + case ecl_htt_not_weak: default: output = ECL_NIL; break; + } #endif - @(return output) + @(return output) } @(defun gethash (key ht &optional (no_value ECL_NIL)) @ { - assert_type_hash_table(@[gethash], 2, ht); - { - cl_object v = ht->hash.get(key, ht, OBJNULL); - if (v != OBJNULL) { - @(return v ECL_T); - } else { - @(return no_value ECL_NIL); - } - } + assert_type_hash_table(@[gethash], 2, ht); + { + cl_object v = ht->hash.get(key, ht, OBJNULL); + if (v != OBJNULL) { + @(return v ECL_T); + } else { + @(return no_value ECL_NIL); + } + } } @) cl_object si_hash_set(cl_object key, cl_object ht, cl_object val) { - /* INV: ecl_sethash() checks the type of hashtable */ - ecl_sethash(key, ht, val); - @(return val) + /* INV: ecl_sethash() checks the type of hashtable */ + ecl_sethash(key, ht, val); + @(return val) } bool ecl_remhash(cl_object key, cl_object hashtable) { - assert_type_hash_table(@[remhash], 2, hashtable); - return hashtable->hash.rem(key, hashtable); + assert_type_hash_table(@[remhash], 2, hashtable); + return hashtable->hash.rem(key, hashtable); } cl_object cl_remhash(cl_object key, cl_object ht) { - /* INV: _ecl_remhash() checks the type of hashtable */ - @(return (ecl_remhash(key, ht)? ECL_T : ECL_NIL)); + /* INV: _ecl_remhash() checks the type of hashtable */ + @(return (ecl_remhash(key, ht)? ECL_T : ECL_NIL)); } cl_object cl_clrhash(cl_object ht) { - assert_type_hash_table(@[clrhash], 1, ht); - if (ht->hash.entries) { - do_clrhash(ht); - } - @(return ht) + assert_type_hash_table(@[clrhash], 1, ht); + if (ht->hash.entries) { + do_clrhash(ht); + } + @(return ht) } cl_object cl_hash_table_test(cl_object ht) { - cl_object output; - assert_type_hash_table(@[hash-table-test], 1, ht); - switch(ht->hash.test) { - case ecl_htt_eq: output = @'eq'; break; - case ecl_htt_eql: output = @'eql'; break; - case ecl_htt_equal: output = @'equal'; break; - case ecl_htt_equalp: output = @'equalp'; break; - case ecl_htt_pack: - default: output = @'equal'; - } - @(return output) + cl_object output; + assert_type_hash_table(@[hash-table-test], 1, ht); + switch(ht->hash.test) { + case ecl_htt_eq: output = @'eq'; break; + case ecl_htt_eql: output = @'eql'; break; + case ecl_htt_equal: output = @'equal'; break; + case ecl_htt_equalp: output = @'equalp'; break; + case ecl_htt_pack: + default: output = @'equal'; + } + @(return output) } cl_object cl_hash_table_size(cl_object ht) { - assert_type_hash_table(@[hash-table-size], 1, ht); - @(return ecl_make_fixnum(ht->hash.size)) + assert_type_hash_table(@[hash-table-size], 1, ht); + @(return ecl_make_fixnum(ht->hash.size)) } cl_index ecl_hash_table_count(cl_object ht) { - if (ht->hash.weak == ecl_htt_not_weak) { - return ht->hash.entries; - } else if (ht->hash.size) { - cl_index i, j; - for (i = j = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry output = - copy_entry(ht->hash.data + i, ht); - if (output.key != OBJNULL) { - if (++j == ht->hash.size) - break; - } - } - return ht->hash.entries = j; - } else { - return 0; - } + if (ht->hash.weak == ecl_htt_not_weak) { + return ht->hash.entries; + } else if (ht->hash.size) { + cl_index i, j; + for (i = j = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry output = + copy_entry(ht->hash.data + i, ht); + if (output.key != OBJNULL) { + if (++j == ht->hash.size) + break; + } + } + return ht->hash.entries = j; + } else { + return 0; + } } cl_object cl_hash_table_count(cl_object ht) { - assert_type_hash_table(@[hash-table-count], 1, ht); - @(return (ecl_make_fixnum(ecl_hash_table_count(ht)))) + assert_type_hash_table(@[hash-table-count], 1, ht); + @(return (ecl_make_fixnum(ecl_hash_table_count(ht)))) } static cl_object si_hash_table_iterate(cl_narg narg) { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object env = the_env->function->cclosure.env; - cl_object index = CAR(env); - cl_object ht = CADR(env); - cl_fixnum i; - if (!Null(index)) { - i = ecl_fixnum(index); - if (i < 0) - i = -1; - for (; ++i < ht->hash.size; ) { - struct ecl_hashtable_entry e = - copy_entry(ht->hash.data + i, ht); - if (e.key != OBJNULL) { - cl_object ndx = ecl_make_fixnum(i); - ECL_RPLACA(env, ndx); - @(return ndx e.key e.value) - } - } - ECL_RPLACA(env, ECL_NIL); - } - @(return ECL_NIL) + cl_object index = CAR(env); + cl_object ht = CADR(env); + cl_fixnum i; + if (!Null(index)) { + i = ecl_fixnum(index); + if (i < 0) + i = -1; + for (; ++i < ht->hash.size; ) { + struct ecl_hashtable_entry e = + copy_entry(ht->hash.data + i, ht); + if (e.key != OBJNULL) { + cl_object ndx = ecl_make_fixnum(i); + ECL_RPLACA(env, ndx); + @(return ndx e.key e.value) + } + } + ECL_RPLACA(env, ECL_NIL); + } + @(return ECL_NIL) } cl_object si_hash_table_iterator(cl_object ht) { - assert_type_hash_table(@[si::hash-table-iterator], 1, ht); - @(return ecl_make_cclosure_va((cl_objectfn)si_hash_table_iterate, + assert_type_hash_table(@[si::hash-table-iterator], 1, ht); + @(return ecl_make_cclosure_va((cl_objectfn)si_hash_table_iterate, cl_list(2, ecl_make_fixnum(-1), ht), @'si::hash-table-iterator')) } @@ -1040,107 +1040,107 @@ si_hash_table_iterator(cl_object ht) cl_object cl_hash_table_rehash_size(cl_object ht) { - assert_type_hash_table(@[hash-table-rehash-size], 1, ht); - @(return ht->hash.rehash_size) + assert_type_hash_table(@[hash-table-rehash-size], 1, ht); + @(return ht->hash.rehash_size) } cl_object cl_hash_table_rehash_threshold(cl_object ht) { - assert_type_hash_table(@[hash-table-rehash-threshold], 1, ht); - @(return ht->hash.threshold) + assert_type_hash_table(@[hash-table-rehash-threshold], 1, ht); + @(return ht->hash.threshold) } cl_object cl_sxhash(cl_object key) { - cl_index output = _hash_equal(3, 0, key); - const cl_index mask = ((cl_index)1 << (FIXNUM_BITS - 3)) - 1; - @(return ecl_make_fixnum(output & mask)) + cl_index output = _hash_equal(3, 0, key); + const cl_index mask = ((cl_index)1 << (FIXNUM_BITS - 3)) - 1; + @(return ecl_make_fixnum(output & mask)) } @(defun si::hash-eql (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_eql(h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_eql(h, o); + } + @(return ecl_make_fixnum(h)) @) @(defun si::hash-equal (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_equal(3, h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_equal(3, h, o); + } + @(return ecl_make_fixnum(h)) @) @(defun si::hash-equalp (&rest args) - cl_index h; + cl_index h; @ - for (h = 0; narg; narg--) { - cl_object o = ecl_va_arg(args); - h = _hash_equalp(3, h, o); - } - @(return ecl_make_fixnum(h)) + for (h = 0; narg; narg--) { + cl_object o = ecl_va_arg(args); + h = _hash_equalp(3, h, o); + } + @(return ecl_make_fixnum(h)) @) cl_object cl_maphash(cl_object fun, cl_object ht) { - cl_index i; + cl_index i; - assert_type_hash_table(@[maphash], 2, ht); - for (i = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry e = ht->hash.data[i]; - if(e.key != OBJNULL) - funcall(3, fun, e.key, e.value); - } - @(return ECL_NIL) + assert_type_hash_table(@[maphash], 2, ht); + for (i = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry e = ht->hash.data[i]; + if(e.key != OBJNULL) + funcall(3, fun, e.key, e.value); + } + @(return ECL_NIL) } cl_object si_hash_table_content(cl_object ht) { - cl_index i; - cl_object output = ECL_NIL; - assert_type_hash_table(@[ext::hash-table-content], 2, ht); - for (i = 0; i < ht->hash.size; i++) { - struct ecl_hashtable_entry e = ht->hash.data[i]; - if (e.key != OBJNULL) - output = ecl_cons(ecl_cons(e.key, e.value), output); - } - @(return output) + cl_index i; + cl_object output = ECL_NIL; + assert_type_hash_table(@[ext::hash-table-content], 2, ht); + for (i = 0; i < ht->hash.size; i++) { + struct ecl_hashtable_entry e = ht->hash.data[i]; + if (e.key != OBJNULL) + output = ecl_cons(ecl_cons(e.key, e.value), output); + } + @(return output) } cl_object si_hash_table_fill(cl_object ht, cl_object values) { - assert_type_hash_table(@[ext::hash-table-fill], 2, ht); - while (!Null(values)) { - cl_object pair = ecl_car(values); - cl_object key = ecl_car(pair); - cl_object value = ECL_CONS_CDR(pair); - values = ECL_CONS_CDR(values); - ecl_sethash(key, ht, value); - } - @(return ht) + assert_type_hash_table(@[ext::hash-table-fill], 2, ht); + while (!Null(values)) { + cl_object pair = ecl_car(values); + cl_object key = ecl_car(pair); + cl_object value = ECL_CONS_CDR(pair); + values = ECL_CONS_CDR(values); + ecl_sethash(key, ht, value); + } + @(return ht) } cl_object si_copy_hash_table(cl_object orig) { - cl_object hash; - hash = cl__make_hash_table(cl_hash_table_test(orig), - cl_hash_table_size(orig), - cl_hash_table_rehash_size(orig), - cl_hash_table_rehash_threshold(orig)); - memcpy(hash->hash.data, orig->hash.data, - orig->hash.size * sizeof(*orig->hash.data)); - hash->hash.entries = orig->hash.entries; - @(return hash) + cl_object hash; + hash = cl__make_hash_table(cl_hash_table_test(orig), + cl_hash_table_size(orig), + cl_hash_table_rehash_size(orig), + cl_hash_table_rehash_threshold(orig)); + memcpy(hash->hash.data, orig->hash.data, + orig->hash.size * sizeof(*orig->hash.data)); + hash->hash.entries = orig->hash.entries; + @(return hash) } diff --git a/src/c/instance.d b/src/c/instance.d index 16f4cc3b8..014369fa0 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -21,101 +21,101 @@ cl_object ecl_allocate_instance(cl_object clas, cl_index size) { - cl_object x = ecl_alloc_instance(size); - cl_index i; - ECL_CLASS_OF(x) = clas; - for (i = 0; i < size; i++) - x->instance.slots[i] = ECL_UNBOUND; - return x; + cl_object x = ecl_alloc_instance(size); + cl_index i; + ECL_CLASS_OF(x) = clas; + for (i = 0; i < size; i++) + x->instance.slots[i] = ECL_UNBOUND; + return x; } cl_object si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size) { - cl_object output = ecl_allocate_instance(clas, ecl_to_size(size)); - if (orig == ECL_NIL) { - orig = output; - } else { - orig->instance.clas = clas; - orig->instance.length = output->instance.length; - orig->instance.slots = output->instance.slots; - } - @(return orig) + cl_object output = ecl_allocate_instance(clas, ecl_to_size(size)); + if (orig == ECL_NIL) { + orig = output; + } else { + orig->instance.clas = clas; + orig->instance.length = output->instance.length; + orig->instance.slots = output->instance.slots; + } + @(return orig) } cl_object si_instance_sig(cl_object x) { - @(return x->instance.sig); + @(return x->instance.sig); } cl_object si_instance_sig_set(cl_object x) { - @(return (x->instance.sig = ECL_CLASS_SLOTS(ECL_CLASS_OF(x)))); + @(return (x->instance.sig = ECL_CLASS_SLOTS(ECL_CLASS_OF(x)))); } cl_object si_instance_class(cl_object x) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_only_arg(@[class-of], x, @[ext::instance]); - @(return ECL_CLASS_OF(x)) + @(return ECL_CLASS_OF(x)) } cl_object si_instance_class_set(cl_object x, cl_object y) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-class-set], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_INSTANCEP(y))) + if (ecl_unlikely(!ECL_INSTANCEP(y))) FEwrong_type_nth_arg(@[si::instance-class-set], 2, y, @[ext::instance]); - ECL_CLASS_OF(x) = y; - @(return x) + ECL_CLASS_OF(x) = y; + @(return x) } cl_object ecl_instance_ref(cl_object x, cl_fixnum i) { - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) - FEtype_error_index(x, i); - return(x->instance.slots[i]); + if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) + FEtype_error_index(x, i); + return(x->instance.slots[i]); } cl_object si_instance_ref(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) - FEtype_error_index(x, i); - @(return x->instance.slots[i]) + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i < 0 || i >= (cl_fixnum)x->instance.length)) + FEtype_error_index(x, i); + @(return x->instance.slots[i]) } #ifdef CLOS cl_object clos_safe_instance_ref(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-ref], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i < 0 || i >= x->instance.length)) - FEtype_error_index(x, i); - x = x->instance.slots[i]; - if (ecl_unlikely(x == ECL_UNBOUND)) - x = _ecl_funcall4(@'slot-unbound', ECL_NIL, x, index); - @(return x) + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-ref], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i < 0 || i >= x->instance.length)) + FEtype_error_index(x, i); + x = x->instance.slots[i]; + if (ecl_unlikely(x == ECL_UNBOUND)) + x = _ecl_funcall4(@'slot-unbound', ECL_NIL, x, index); + @(return x) } #endif @@ -124,284 +124,284 @@ ecl_instance_set(cl_object x, cl_fixnum i, cl_object v) { if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); - if (ecl_unlikely(i >= x->instance.length || i < 0)) - FEtype_error_index(x, i); - x->instance.slots[i] = v; - return(v); + if (ecl_unlikely(i >= x->instance.length || i < 0)) + FEtype_error_index(x, i); + x->instance.slots[i] = v; + return(v); } cl_object si_instance_set(cl_object x, cl_object index, cl_object value) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::instance-set], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::instance-set], 2, index, @[fixnum]); - i = ecl_fixnum(index); - if (ecl_unlikely(i >= (cl_fixnum)x->instance.length || i < 0)) - FEtype_error_index(x, i); - x->instance.slots[i] = value; - @(return value) + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::instance-set], 2, index, @[fixnum]); + i = ecl_fixnum(index); + if (ecl_unlikely(i >= (cl_fixnum)x->instance.length || i < 0)) + FEtype_error_index(x, i); + x->instance.slots[i] = value; + @(return value) } cl_object si_instancep(cl_object x) { - @(return (ECL_INSTANCEP(x) ? ecl_make_fixnum(x->instance.length) : ECL_NIL)) + @(return (ECL_INSTANCEP(x) ? ecl_make_fixnum(x->instance.length) : ECL_NIL)) } cl_object si_unbound() { - /* Returns an object that cannot be read or written and which - is used to represent an unitialized slot */ - @(return ECL_UNBOUND) + /* Returns an object that cannot be read or written and which + is used to represent an unitialized slot */ + @(return ECL_UNBOUND) } cl_object si_sl_boundp(cl_object x) { - @(return ((x == ECL_UNBOUND) ? ECL_NIL : ECL_T)) + @(return ((x == ECL_UNBOUND) ? ECL_NIL : ECL_T)) } cl_object si_sl_makunbound(cl_object x, cl_object index) { - cl_fixnum i; + cl_fixnum i; - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::sl-makunbound], 1, x, @[ext::instance]); - if (ecl_unlikely(!ECL_FIXNUMP(index))) - FEwrong_type_nth_arg(@[si::sl-makunbound], 2, index, @[fixnum]); - i = ecl_fixnum(index); - unlikely_if (i >= x->instance.length || i < 0) - FEtype_error_index(x, i); - x->instance.slots[i] = ECL_UNBOUND; - @(return x) + if (ecl_unlikely(!ECL_FIXNUMP(index))) + FEwrong_type_nth_arg(@[si::sl-makunbound], 2, index, @[fixnum]); + i = ecl_fixnum(index); + unlikely_if (i >= x->instance.length || i < 0) + FEtype_error_index(x, i); + x->instance.slots[i] = ECL_UNBOUND; + @(return x) } cl_object si_copy_instance(cl_object x) { - cl_object y; + cl_object y; - if (ecl_unlikely(!ECL_INSTANCEP(x))) + if (ecl_unlikely(!ECL_INSTANCEP(x))) FEwrong_type_nth_arg(@[si::copy-instance], 1, x, @[ext::instance]); - y = ecl_allocate_instance(x->instance.clas, x->instance.length); - y->instance.sig = x->instance.sig; - memcpy(y->instance.slots, x->instance.slots, - x->instance.length * sizeof(cl_object)); - @(return y) + y = ecl_allocate_instance(x->instance.clas, x->instance.length); + y->instance.sig = x->instance.sig; + memcpy(y->instance.slots, x->instance.slots, + x->instance.length * sizeof(cl_object)); + @(return y) } @(defun find-class (name &optional (errorp ECL_T) env) - cl_object class, hash; + cl_object class, hash; @ - hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*'); - class = ecl_gethash_safe(name, hash, ECL_NIL); - if (class == ECL_NIL) { - if (!Null(errorp)) - FEerror("No class named ~S.", 1, name); - } - @(return class) + hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*'); + class = ecl_gethash_safe(name, hash, ECL_NIL); + if (class == ECL_NIL) { + if (!Null(errorp)) + FEerror("No class named ~S.", 1, name); + } + @(return class) @) cl_object ecl_slot_value(cl_object x, const char *slot) { - cl_object slot_name = ecl_read_from_cstring(slot); - return funcall(3, @'slot-value', x, slot_name); + cl_object slot_name = ecl_read_from_cstring(slot); + return funcall(3, @'slot-value', x, slot_name); } cl_object ecl_slot_value_set(cl_object x, const char *slot, cl_object value) { - cl_object slot_name = ecl_read_from_cstring(slot); - cl_object slot_setter = ecl_read_from_cstring("(SETF SLOT-VALUE)"); - return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name); + cl_object slot_name = ecl_read_from_cstring(slot); + cl_object slot_setter = ecl_read_from_cstring("(SETF SLOT-VALUE)"); + return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name); } /********************************************************************** * IMPORTANT: THE FOLLOWING LIST IS LINKED TO src/clos/builtin.lsp **********************************************************************/ enum ecl_built_in_classes { - ECL_BUILTIN_T = 0, - ECL_BUILTIN_SEQUENCE, - ECL_BUILTIN_LIST, - ECL_BUILTIN_CONS, - ECL_BUILTIN_ARRAY, - ECL_BUILTIN_VECTOR, - ECL_BUILTIN_STRING, + ECL_BUILTIN_T = 0, + ECL_BUILTIN_SEQUENCE, + ECL_BUILTIN_LIST, + ECL_BUILTIN_CONS, + ECL_BUILTIN_ARRAY, + ECL_BUILTIN_VECTOR, + ECL_BUILTIN_STRING, #ifdef ECL_UNICODE - ECL_BUILTIN_BASE_STRING, + ECL_BUILTIN_BASE_STRING, #endif - ECL_BUILTIN_BIT_VECTOR, - ECL_BUILTIN_STREAM, - ECL_BUILTIN_ANSI_STREAM, - ECL_BUILTIN_FILE_STREAM, - ECL_BUILTIN_ECHO_STREAM, - ECL_BUILTIN_STRING_STREAM, - ECL_BUILTIN_TWO_WAY_STREAM, - ECL_BUILTIN_SYNONYM_STREAM, - ECL_BUILTIN_BROADCAST_STREAM, - ECL_BUILTIN_CONCATENATED_STREAM, - ECL_BUILTIN_SEQUENCE_STREAM, - ECL_BUILTIN_CHARACTER, - ECL_BUILTIN_NUMBER, - ECL_BUILTIN_REAL, - ECL_BUILTIN_RATIONAL, - ECL_BUILTIN_INTEGER, - ECL_BUILTIN_FIXNUM, - ECL_BUILTIN_BIGNUM, - ECL_BUILTIN_RATIO, - ECL_BUILTIN_FLOAT, - ECL_BUILTIN_COMPLEX, - ECL_BUILTIN_SYMBOL, - ECL_BUILTIN_NULL, - ECL_BUILTIN_KEYWORD, - ECL_BUILTIN_PACKAGE, - ECL_BUILTIN_FUNCTION, - ECL_BUILTIN_PATHNAME, - ECL_BUILTIN_LOGICAL_PATHNAME, - ECL_BUILTIN_HASH_TABLE, - ECL_BUILTIN_RANDOM_STATE, - ECL_BUILTIN_READTABLE, - ECL_BUILTIN_CODE_BLOCK, - ECL_BUILTIN_FOREIGN_DATA, - ECL_BUILTIN_FRAME, - ECL_BUILTIN_WEAK_POINTER + ECL_BUILTIN_BIT_VECTOR, + ECL_BUILTIN_STREAM, + ECL_BUILTIN_ANSI_STREAM, + ECL_BUILTIN_FILE_STREAM, + ECL_BUILTIN_ECHO_STREAM, + ECL_BUILTIN_STRING_STREAM, + ECL_BUILTIN_TWO_WAY_STREAM, + ECL_BUILTIN_SYNONYM_STREAM, + ECL_BUILTIN_BROADCAST_STREAM, + ECL_BUILTIN_CONCATENATED_STREAM, + ECL_BUILTIN_SEQUENCE_STREAM, + ECL_BUILTIN_CHARACTER, + ECL_BUILTIN_NUMBER, + ECL_BUILTIN_REAL, + ECL_BUILTIN_RATIONAL, + ECL_BUILTIN_INTEGER, + ECL_BUILTIN_FIXNUM, + ECL_BUILTIN_BIGNUM, + ECL_BUILTIN_RATIO, + ECL_BUILTIN_FLOAT, + ECL_BUILTIN_COMPLEX, + ECL_BUILTIN_SYMBOL, + ECL_BUILTIN_NULL, + ECL_BUILTIN_KEYWORD, + ECL_BUILTIN_PACKAGE, + ECL_BUILTIN_FUNCTION, + ECL_BUILTIN_PATHNAME, + ECL_BUILTIN_LOGICAL_PATHNAME, + ECL_BUILTIN_HASH_TABLE, + ECL_BUILTIN_RANDOM_STATE, + ECL_BUILTIN_READTABLE, + ECL_BUILTIN_CODE_BLOCK, + ECL_BUILTIN_FOREIGN_DATA, + ECL_BUILTIN_FRAME, + ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS , - ECL_BUILTIN_PROCESS, - ECL_BUILTIN_LOCK, - ECL_BUILTIN_RWLOCK, - ECL_BUILTIN_CONDITION_VARIABLE, + ECL_BUILTIN_PROCESS, + ECL_BUILTIN_LOCK, + ECL_BUILTIN_RWLOCK, + ECL_BUILTIN_CONDITION_VARIABLE, ECL_BUILTIN_SEMAPHORE, - ECL_BUILTIN_BARRIER, - ECL_BUILTIN_MAILBOX + ECL_BUILTIN_BARRIER, + ECL_BUILTIN_MAILBOX #endif #ifdef ECL_SSE2 - , ECL_BUILTIN_SSE_PACK + , ECL_BUILTIN_SSE_PACK #endif }; cl_object cl_class_of(cl_object x) { - size_t index; - switch (ecl_t_of(x)) { - case t_instance: - @(return ECL_CLASS_OF(x)) - case t_fixnum: - index = ECL_BUILTIN_FIXNUM; break; - case t_bignum: - index = ECL_BUILTIN_BIGNUM; break; - case t_ratio: - index = ECL_BUILTIN_RATIO; break; - case t_singlefloat: - case t_doublefloat: + size_t index; + switch (ecl_t_of(x)) { + case t_instance: + @(return ECL_CLASS_OF(x)) + case t_fixnum: + index = ECL_BUILTIN_FIXNUM; break; + case t_bignum: + index = ECL_BUILTIN_BIGNUM; break; + case t_ratio: + index = ECL_BUILTIN_RATIO; break; + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - index = ECL_BUILTIN_FLOAT; break; - /* XXX index = ECL_BUILTIN_long-float; break; */ - case t_complex: - index = ECL_BUILTIN_COMPLEX; break; - case t_character: - index = ECL_BUILTIN_CHARACTER; break; - case t_symbol: - if (x->symbol.hpack == cl_core.keyword_package) - index = ECL_BUILTIN_KEYWORD; - else - index = ECL_BUILTIN_SYMBOL; - break; - case t_package: - index = ECL_BUILTIN_PACKAGE; break; - case t_list: - index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break; - case t_hashtable: - index = ECL_BUILTIN_HASH_TABLE; break; - case t_array: - index = ECL_BUILTIN_ARRAY; break; - case t_vector: - index = ECL_BUILTIN_VECTOR; break; + index = ECL_BUILTIN_FLOAT; break; + /* XXX index = ECL_BUILTIN_long-float; break; */ + case t_complex: + index = ECL_BUILTIN_COMPLEX; break; + case t_character: + index = ECL_BUILTIN_CHARACTER; break; + case t_symbol: + if (x->symbol.hpack == cl_core.keyword_package) + index = ECL_BUILTIN_KEYWORD; + else + index = ECL_BUILTIN_SYMBOL; + break; + case t_package: + index = ECL_BUILTIN_PACKAGE; break; + case t_list: + index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break; + case t_hashtable: + index = ECL_BUILTIN_HASH_TABLE; break; + case t_array: + index = ECL_BUILTIN_ARRAY; break; + case t_vector: + index = ECL_BUILTIN_VECTOR; break; #ifdef ECL_UNICODE - case t_string: - index = ECL_BUILTIN_STRING; break; - case t_base_string: - index = ECL_BUILTIN_BASE_STRING; break; + case t_string: + index = ECL_BUILTIN_STRING; break; + case t_base_string: + index = ECL_BUILTIN_BASE_STRING; break; #else - case t_base_string: - index = ECL_BUILTIN_STRING; break; + case t_base_string: + index = ECL_BUILTIN_STRING; break; #endif - case t_bitvector: - index = ECL_BUILTIN_BIT_VECTOR; break; - case t_stream: - switch (x->stream.mode) { - case ecl_smm_synonym: index = ECL_BUILTIN_SYNONYM_STREAM; break; - case ecl_smm_broadcast: index = ECL_BUILTIN_BROADCAST_STREAM; break; - case ecl_smm_concatenated: index = ECL_BUILTIN_CONCATENATED_STREAM; break; - case ecl_smm_two_way: index = ECL_BUILTIN_TWO_WAY_STREAM; break; - case ecl_smm_string_input: - case ecl_smm_string_output: index = ECL_BUILTIN_STRING_STREAM; break; - case ecl_smm_echo: index = ECL_BUILTIN_ECHO_STREAM; break; + case t_bitvector: + index = ECL_BUILTIN_BIT_VECTOR; break; + case t_stream: + switch (x->stream.mode) { + case ecl_smm_synonym: index = ECL_BUILTIN_SYNONYM_STREAM; break; + case ecl_smm_broadcast: index = ECL_BUILTIN_BROADCAST_STREAM; break; + case ecl_smm_concatenated: index = ECL_BUILTIN_CONCATENATED_STREAM; break; + case ecl_smm_two_way: index = ECL_BUILTIN_TWO_WAY_STREAM; break; + case ecl_smm_string_input: + case ecl_smm_string_output: index = ECL_BUILTIN_STRING_STREAM; break; + case ecl_smm_echo: index = ECL_BUILTIN_ECHO_STREAM; break; case ecl_smm_sequence_input: case ecl_smm_sequence_output: index = ECL_BUILTIN_SEQUENCE_STREAM; break; - default: index = ECL_BUILTIN_FILE_STREAM; break; - } - break; - case t_readtable: - index = ECL_BUILTIN_READTABLE; break; - case t_pathname: - index = ECL_BUILTIN_PATHNAME; break; - case t_random: - index = ECL_BUILTIN_RANDOM_STATE; break; - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - index = ECL_BUILTIN_FUNCTION; break; + default: index = ECL_BUILTIN_FILE_STREAM; break; + } + break; + case t_readtable: + index = ECL_BUILTIN_READTABLE; break; + case t_pathname: + index = ECL_BUILTIN_PATHNAME; break; + case t_random: + index = ECL_BUILTIN_RANDOM_STATE; break; + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + index = ECL_BUILTIN_FUNCTION; break; #ifdef ECL_THREADS - case t_process: - index = ECL_BUILTIN_PROCESS; break; - case t_lock: - index = ECL_BUILTIN_LOCK; break; - case t_condition_variable: - index = ECL_BUILTIN_CONDITION_VARIABLE; break; - case t_semaphore: - index = ECL_BUILTIN_SEMAPHORE; break; - case t_barrier: - index = ECL_BUILTIN_BARRIER; break; - case t_mailbox: - index = ECL_BUILTIN_MAILBOX; break; + case t_process: + index = ECL_BUILTIN_PROCESS; break; + case t_lock: + index = ECL_BUILTIN_LOCK; break; + case t_condition_variable: + index = ECL_BUILTIN_CONDITION_VARIABLE; break; + case t_semaphore: + index = ECL_BUILTIN_SEMAPHORE; break; + case t_barrier: + index = ECL_BUILTIN_BARRIER; break; + case t_mailbox: + index = ECL_BUILTIN_MAILBOX; break; #endif - case t_codeblock: - index = ECL_BUILTIN_CODE_BLOCK; break; - case t_foreign: - index = ECL_BUILTIN_FOREIGN_DATA; break; - case t_frame: - index = ECL_BUILTIN_FRAME; break; - case t_weak_pointer: - index = ECL_BUILTIN_WEAK_POINTER; break; + case t_codeblock: + index = ECL_BUILTIN_CODE_BLOCK; break; + case t_foreign: + index = ECL_BUILTIN_FOREIGN_DATA; break; + case t_frame: + index = ECL_BUILTIN_FRAME; break; + case t_weak_pointer: + index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 - case t_sse_pack: - index = ECL_BUILTIN_SSE_PACK; break; + case t_sse_pack: + index = ECL_BUILTIN_SSE_PACK; break; #endif - default: - ecl_internal_error("not a lisp data object"); - } - { - /* We have to be careful because +builtin-classes+ might be empty! */ - /* In any case, since +builtin-classes+ is a constant, we may - * optimize the slot access */ - cl_object v = @'clos::+builtin-classes+'->symbol.value; - cl_object output = Null(v)? - cl_find_class(1,@'t') : - v->vector.self.t[index]; - @(return output) - } + default: + ecl_internal_error("not a lisp data object"); + } + { + /* We have to be careful because +builtin-classes+ might be empty! */ + /* In any case, since +builtin-classes+ is a constant, we may + * optimize the slot access */ + cl_object v = @'clos::+builtin-classes+'->symbol.value; + cl_object output = Null(v)? + cl_find_class(1,@'t') : + v->vector.self.t[index]; + @(return output) + } } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index a80f4bb0c..b8d65d118 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -26,33 +26,33 @@ cl_object * ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { - cl_index top = env->stack_top - env->stack; - cl_object *new_stack, *old_stack; - cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - cl_index new_size = tentative_new_size + 2*safety_area; + cl_index top = env->stack_top - env->stack; + cl_object *new_stack, *old_stack; + cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + cl_index new_size = tentative_new_size + 2*safety_area; /* Round to page size */ new_size = (new_size + (LISP_PAGESIZE-1))/LISP_PAGESIZE * new_size; - if (ecl_unlikely(top > new_size)) { - FEerror("Internal error: cannot shrink stack below stack top.",0); + if (ecl_unlikely(top > new_size)) { + FEerror("Internal error: cannot shrink stack below stack top.",0); } - old_stack = env->stack; - new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); + old_stack = env->stack; + new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); - ecl_disable_interrupts_env(env); - memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); - env->stack_size = new_size; - env->stack = new_stack; - env->stack_top = env->stack + top; - env->stack_limit = env->stack + (new_size - 2*safety_area); - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); + env->stack_size = new_size; + env->stack = new_stack; + env->stack_top = env->stack + top; + env->stack_limit = env->stack + (new_size - 2*safety_area); + ecl_enable_interrupts_env(env); - /* A stack always has at least one element. This is assumed by cl__va_start - * and friends, which take a sp=0 to have no arguments. - */ - if (top == 0) { + /* A stack always has at least one element. This is assumed by cl__va_start + * and friends, which take a sp=0 to have no arguments. + */ + if (top == 0) { *(env->stack_top++) = ecl_make_fixnum(0); } return env->stack_top; @@ -73,7 +73,7 @@ FEstack_advance(void) cl_object * ecl_stack_grow(cl_env_ptr env) { - return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); + return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); } cl_index @@ -87,7 +87,7 @@ ecl_stack_push_values(cl_env_ptr env) { } env->stack_top = p; memcpy(b, env->values, i * sizeof(cl_object)); - return i; + return i; } void @@ -103,31 +103,31 @@ ecl_stack_pop_values(cl_env_ptr env, cl_index n) { cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) { - cl_object *base = env->stack_top; - if (size) { - if ((env->stack_limit - base) < size) { - base = ecl_stack_set_size(env, env->stack_size + size); - } - } - f->frame.t = t_frame; - f->frame.stack = env->stack; - f->frame.base = base; + cl_object *base = env->stack_top; + if (size) { + if ((env->stack_limit - base) < size) { + base = ecl_stack_set_size(env, env->stack_size + size); + } + } + f->frame.t = t_frame; + f->frame.stack = env->stack; + f->frame.base = base; f->frame.size = size; - f->frame.env = env; - env->stack_top = (base + size); - return f; + f->frame.env = env; + env->stack_top = (base + size); + return f; } void ecl_stack_frame_push(cl_object f, cl_object o) { - cl_env_ptr env = f->frame.env; - cl_object *top = env->stack_top; - if (top >= env->stack_limit) { - top = ecl_stack_grow(env); - } - *top = o; - env->stack_top = ++top; + cl_env_ptr env = f->frame.env; + cl_object *top = env->stack_top; + if (top >= env->stack_limit) { + top = ecl_stack_grow(env); + } + *top = o; + env->stack_top = ++top; f->frame.base = top - (++(f->frame.size)); f->frame.stack = env->stack; } @@ -135,47 +135,47 @@ ecl_stack_frame_push(cl_object f, cl_object o) void ecl_stack_frame_push_values(cl_object f) { - cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); + cl_env_ptr env = f->frame.env; + ecl_stack_push_values(env); f->frame.base = env->stack_top - (f->frame.size += env->nvalues); - f->frame.stack = env->stack; + f->frame.stack = env->stack; } cl_object ecl_stack_frame_pop_values(cl_object f) { cl_env_ptr env = f->frame.env; - cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT; + cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT; cl_object o; env->nvalues = n; env->values[0] = o = ECL_NIL; - while (n--) { + while (n--) { env->values[n] = o = f->frame.base[n]; - } - return o; + } + return o; } void ecl_stack_frame_close(cl_object f) { - if (f->frame.stack) { - ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack); - } + if (f->frame.stack) { + ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack); + } } /* ------------------------------ LEXICAL ENV. ------------------------------ */ -#define bind_var(env, var, val) CONS(CONS(var, val), (env)) -#define bind_function(env, name, fun) CONS(fun, (env)) -#define bind_frame(env, id, name) CONS(CONS(id, name), (env)) +#define bind_var(env, var, val) CONS(CONS(var, val), (env)) +#define bind_function(env, name, fun) CONS(fun, (env)) +#define bind_frame(env, id, name) CONS(CONS(id, name), (env)) static cl_object ecl_lex_env_get_record(register cl_object env, register int s) { - do { - if (s-- == 0) return ECL_CONS_CAR(env); - env = ECL_CONS_CDR(env); - } while(1); + do { + if (s-- == 0) return ECL_CONS_CAR(env); + env = ECL_CONS_CDR(env); + } while(1); } #define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) @@ -190,8 +190,8 @@ _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...) { cl_object output; ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) { - output = ecl_interpret(frame, ECL_NIL, frame->frame.env->function); - } ECL_STACK_FRAME_VARARGS_END(frame); + output = ecl_interpret(frame, ECL_NIL, frame->frame.env->function); + } ECL_STACK_FRAME_VARARGS_END(frame); return output; } @@ -208,13 +208,13 @@ _ecl_bclosure_dispatch_vararg(cl_narg narg, ...) static cl_object close_around(cl_object fun, cl_object lex) { - cl_object v = ecl_alloc_object(t_bclosure); - if (ecl_t_of(fun) != t_bytecodes) - FEerror("!!!", 0); - v->bclosure.code = fun; - v->bclosure.lex = lex; + cl_object v = ecl_alloc_object(t_bclosure); + if (ecl_t_of(fun) != t_bytecodes) + FEerror("!!!", 0); + v->bclosure.code = fun; + v->bclosure.lex = lex; v->bclosure.entry = _ecl_bclosure_dispatch_vararg; - return v; + return v; } #define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } @@ -268,325 +268,325 @@ unknown_keyword(register cl_object bytecodes, register cl_object frame) cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) { - ECL_OFFSET_TABLE + ECL_OFFSET_TABLE const cl_env_ptr the_env = frame->frame.env; volatile cl_index frame_index = 0; - cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code; - cl_object *data = bytecodes->bytecodes.data->vector.self.t; - cl_object reg0, reg1, lex_env = env; - cl_index narg; - struct ecl_stack_frame frame_aux; - volatile struct ecl_ihs_frame ihs; + cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code; + cl_object *data = bytecodes->bytecodes.data->vector.self.t; + cl_object reg0, reg1, lex_env = env; + cl_index narg; + struct ecl_stack_frame frame_aux; + volatile struct ecl_ihs_frame ihs; /* INV: bytecodes is of type t_bytecodes */ - ecl_cs_check(the_env, ihs); - ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); - frame_aux.t = t_frame; - frame_aux.stack = frame_aux.base = 0; + ecl_cs_check(the_env, ihs); + ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); + frame_aux.t = t_frame; + frame_aux.stack = frame_aux.base = 0; frame_aux.size = 0; frame_aux.env = the_env; BEGIN: - BEGIN_SWITCH { - CASE(OP_NOP); { - reg0 = ECL_NIL; - the_env->nvalues = 0; - THREAD_NEXT; - } - /* OP_QUOTE - Sets REG0 to an immediate value. - */ - CASE(OP_QUOTE); { - GET_DATA(reg0, vector, data); - THREAD_NEXT; - } - /* OP_VAR n{arg}, var{symbol} - Sets REG0 to the value of the n-th local. - VAR is the name of the variable for readability purposes. - */ - CASE(OP_VAR); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); - THREAD_NEXT; - } + BEGIN_SWITCH { + CASE(OP_NOP); { + reg0 = ECL_NIL; + the_env->nvalues = 0; + THREAD_NEXT; + } + /* OP_QUOTE + Sets REG0 to an immediate value. + */ + CASE(OP_QUOTE); { + GET_DATA(reg0, vector, data); + THREAD_NEXT; + } + /* OP_VAR n{arg}, var{symbol} + Sets REG0 to the value of the n-th local. + VAR is the name of the variable for readability purposes. + */ + CASE(OP_VAR); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); + THREAD_NEXT; + } - /* OP_VARS var{symbol} - Sets REG0 to the value of the symbol VAR. - VAR should be either a special variable or a constant. - */ - CASE(OP_VARS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - reg0 = ECL_SYM_VAL(the_env, var_name); - if (ecl_unlikely(reg0 == OBJNULL)) - FEunbound_variable(var_name); - THREAD_NEXT; - } - - /* OP_CONS, OP_CAR, OP_CDR, etc - Inlined forms for some functions which act on reg0 and stack. - */ - - CASE(OP_CONS); { - cl_object car = ECL_STACK_POP_UNSAFE(the_env); - reg0 = CONS(car, reg0); - THREAD_NEXT; - } - - CASE(OP_CAR); { - if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[car], reg0, @[cons]); - reg0 = CAR(reg0); - THREAD_NEXT; - } - - CASE(OP_CDR); { - if (ecl_unlikely(!LISTP(reg0))) - FEwrong_type_only_arg(@[cdr], reg0, @[cons]); - reg0 = CDR(reg0); - THREAD_NEXT; - } - - CASE(OP_LIST); - reg0 = ecl_list1(reg0); - - CASE(OP_LISTA); { - cl_index n; - GET_OPARG(n, vector); - while (--n) { - reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); - } - THREAD_NEXT; - } - - CASE(OP_INT); { - cl_fixnum n; - GET_OPARG(n, vector); - reg0 = ecl_make_fixnum(n); - THREAD_NEXT; - } - - CASE(OP_PINT); { - cl_fixnum n; - GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); - THREAD_NEXT; - } - - /* OP_PUSH - Pushes the object in VALUES(0). - */ - CASE(OP_PUSH); { - ECL_STACK_PUSH(the_env, reg0); - THREAD_NEXT; - } - /* OP_PUSHV n{arg} - Pushes the value of the n-th local onto the stack. - */ - CASE(OP_PUSHV); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); - THREAD_NEXT; - } - - /* OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - VAR should be either a special variable or a constant. - */ - CASE(OP_PUSHVS); { - cl_object var_name, value; - GET_DATA(var_name, vector, data); - value = ECL_SYM_VAL(the_env, var_name); - if (ecl_unlikely(value == OBJNULL)) + /* OP_VARS var{symbol} + Sets REG0 to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + CASE(OP_VARS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + reg0 = ECL_SYM_VAL(the_env, var_name); + if (ecl_unlikely(reg0 == OBJNULL)) FEunbound_variable(var_name); - ECL_STACK_PUSH(the_env, value); - THREAD_NEXT; - } + THREAD_NEXT; + } - /* OP_PUSHQ value{object} - Pushes "value" onto the stack. - */ - CASE(OP_PUSHQ); { - cl_object aux; - GET_DATA(aux, vector, data); - ECL_STACK_PUSH(the_env, aux); - THREAD_NEXT; - } + /* OP_CONS, OP_CAR, OP_CDR, etc + Inlined forms for some functions which act on reg0 and stack. + */ - CASE(OP_CALLG1); { - cl_object s; - cl_objectfn f; - GET_DATA(s, vector, data); - f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); - SETUP_ENV(the_env); - reg0 = f(1, reg0); - THREAD_NEXT; - } + CASE(OP_CONS); { + cl_object car = ECL_STACK_POP_UNSAFE(the_env); + reg0 = CONS(car, reg0); + THREAD_NEXT; + } - CASE(OP_CALLG2); { - cl_object s; - cl_objectfn f; - GET_DATA(s, vector, data); - f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); - SETUP_ENV(the_env); - reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); - THREAD_NEXT; - } + CASE(OP_CAR); { + if (ecl_unlikely(!LISTP(reg0))) + FEwrong_type_only_arg(@[car], reg0, @[cons]); + reg0 = CAR(reg0); + THREAD_NEXT; + } - /* OP_CALL n{arg} - Calls the function in REG0 with N arguments which - have been deposited in the stack. The first output value - is pushed on the stack. - */ - CASE(OP_CALL); { - GET_OPARG(narg, vector); - goto DO_CALL; - } + CASE(OP_CDR); { + if (ecl_unlikely(!LISTP(reg0))) + FEwrong_type_only_arg(@[cdr], reg0, @[cons]); + reg0 = CDR(reg0); + THREAD_NEXT; + } - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The first output value is pushed on - the stack. - */ - CASE(OP_CALLG); { - GET_OPARG(narg, vector); - GET_DATA(reg0, vector, data); - goto DO_CALL; - } + CASE(OP_LIST); + reg0 = ecl_list1(reg0); - /* OP_FCALL n{arg} - Calls a function in the stack with N arguments which - have been also deposited in the stack. The output values - are left in VALUES(...) - */ - CASE(OP_FCALL); { - GET_OPARG(narg, vector); - reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; - } + CASE(OP_LISTA); { + cl_index n; + GET_OPARG(n, vector); + while (--n) { + reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); + } + THREAD_NEXT; + } - /* OP_MCALL - Similar to FCALL, but gets the number of arguments from - the stack (They all have been deposited by OP_PUSHVALUES) - */ - CASE(OP_MCALL); { - narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - reg0 = ECL_STACK_REF(the_env,-narg-1); - goto DO_CALL; - } + CASE(OP_INT); { + cl_fixnum n; + GET_OPARG(n, vector); + reg0 = ecl_make_fixnum(n); + THREAD_NEXT; + } - DO_CALL: { - cl_object x = reg0; - cl_object frame = (cl_object)&frame_aux; - frame_aux.size = narg; - frame_aux.base = the_env->stack_top - narg; - SETUP_ENV(the_env); - AGAIN: - if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(reg0)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) - FEwrong_num_arguments(reg0); - reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, + CASE(OP_PINT); { + cl_fixnum n; + GET_OPARG(n, vector); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + THREAD_NEXT; + } + + /* OP_PUSH + Pushes the object in VALUES(0). + */ + CASE(OP_PUSH); { + ECL_STACK_PUSH(the_env, reg0); + THREAD_NEXT; + } + /* OP_PUSHV n{arg} + Pushes the value of the n-th local onto the stack. + */ + CASE(OP_PUSHV); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); + THREAD_NEXT; + } + + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + CASE(OP_PUSHVS); { + cl_object var_name, value; + GET_DATA(var_name, vector, data); + value = ECL_SYM_VAL(the_env, var_name); + if (ecl_unlikely(value == OBJNULL)) + FEunbound_variable(var_name); + ECL_STACK_PUSH(the_env, value); + THREAD_NEXT; + } + + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + CASE(OP_PUSHQ); { + cl_object aux; + GET_DATA(aux, vector, data); + ECL_STACK_PUSH(the_env, aux); + THREAD_NEXT; + } + + CASE(OP_CALLG1); { + cl_object s; + cl_objectfn f; + GET_DATA(s, vector, data); + f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); + SETUP_ENV(the_env); + reg0 = f(1, reg0); + THREAD_NEXT; + } + + CASE(OP_CALLG2); { + cl_object s; + cl_objectfn f; + GET_DATA(s, vector, data); + f = ecl_function_dispatch(the_env, ECL_SYM_FUN(s)); + SETUP_ENV(the_env); + reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); + THREAD_NEXT; + } + + /* OP_CALL n{arg} + Calls the function in REG0 with N arguments which + have been deposited in the stack. The first output value + is pushed on the stack. + */ + CASE(OP_CALL); { + GET_OPARG(narg, vector); + goto DO_CALL; + } + + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The first output value is pushed on + the stack. + */ + CASE(OP_CALLG); { + GET_OPARG(narg, vector); + GET_DATA(reg0, vector, data); + goto DO_CALL; + } + + /* OP_FCALL n{arg} + Calls a function in the stack with N arguments which + have been also deposited in the stack. The output values + are left in VALUES(...) + */ + CASE(OP_FCALL); { + GET_OPARG(narg, vector); + reg0 = ECL_STACK_REF(the_env,-narg-1); + goto DO_CALL; + } + + /* OP_MCALL + Similar to FCALL, but gets the number of arguments from + the stack (They all have been deposited by OP_PUSHVALUES) + */ + CASE(OP_MCALL); { + narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + reg0 = ECL_STACK_REF(the_env,-narg-1); + goto DO_CALL; + } + + DO_CALL: { + cl_object x = reg0; + cl_object frame = (cl_object)&frame_aux; + frame_aux.size = narg; + frame_aux.base = the_env->stack_top - narg; + SETUP_ENV(the_env); + AGAIN: + if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(reg0)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)reg0->cfunfixed.narg)) + FEwrong_num_arguments(reg0); + reg0 = APPLY_fixed(narg, reg0->cfunfixed.entry_fixed, frame_aux.base); - break; - case t_cfun: - reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base); - break; - case t_cclosure: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base); - break; + break; + case t_cfun: + reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.base); + break; + case t_cclosure: + the_env->function = reg0; + reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.base); + break; #ifdef CLOS - case t_instance: - switch (reg0->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - reg0 = _ecl_standard_dispatch(frame, reg0); - break; - case ECL_USER_DISPATCH: - reg0 = reg0->instance.slots[reg0->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - the_env->function = reg0; - reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); - break; - default: - FEinvalid_function(reg0); - } - break; + case t_instance: + switch (reg0->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + reg0 = _ecl_standard_dispatch(frame, reg0); + break; + case ECL_USER_DISPATCH: + reg0 = reg0->instance.slots[reg0->instance.length - 1]; + goto AGAIN; + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + the_env->function = reg0; + reg0 = APPLY(narg, reg0->instance.entry, frame_aux.base); + break; + default: + FEinvalid_function(reg0); + } + break; #endif - case t_symbol: - if (ecl_unlikely(reg0->symbol.stype & ecl_stp_macro)) - FEundefined_function(x); - reg0 = ECL_SYM_FUN(reg0); - goto AGAIN; - case t_bytecodes: - reg0 = ecl_interpret(frame, ECL_NIL, reg0); - break; - case t_bclosure: - reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); - break; - default: - FEinvalid_function(reg0); - } - ECL_STACK_POP_N_UNSAFE(the_env, narg); - THREAD_NEXT; - } + case t_symbol: + if (ecl_unlikely(reg0->symbol.stype & ecl_stp_macro)) + FEundefined_function(x); + reg0 = ECL_SYM_FUN(reg0); + goto AGAIN; + case t_bytecodes: + reg0 = ecl_interpret(frame, ECL_NIL, reg0); + break; + case t_bclosure: + reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code); + break; + default: + FEinvalid_function(reg0); + } + ECL_STACK_POP_N_UNSAFE(the_env, narg); + THREAD_NEXT; + } - /* OP_POP - Pops a singe value pushed by a OP_PUSH* operator. - */ - CASE(OP_POP); { - reg0 = ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } - /* OP_POP1 - Pops a singe value pushed by a OP_PUSH* operator, ignoring it. - */ - CASE(OP_POP1); { - (void)ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } - /* OP_POPREQ - Checks the arguments list. If there are remaining arguments, + /* OP_POP + Pops a singe value pushed by a OP_PUSH* operator. + */ + CASE(OP_POP); { + reg0 = ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } + /* OP_POP1 + Pops a singe value pushed by a OP_PUSH* operator, ignoring it. + */ + CASE(OP_POP1); { + (void)ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } + /* OP_POPREQ + Checks the arguments list. If there are remaining arguments, REG0 = T and the value is on the stack, otherwise REG0 = NIL. - */ - CASE(OP_POPREQ); { - if (ecl_unlikely(frame_index >= frame->frame.size)) { + */ + CASE(OP_POPREQ); { + if (ecl_unlikely(frame_index >= frame->frame.size)) { FEwrong_num_arguments(bytecodes->bytecodes.name); } reg0 = frame->frame.base[frame_index++]; THREAD_NEXT; - } - /* OP_POPOPT - Checks the arguments list. If there are remaining arguments, + } + /* OP_POPOPT + Checks the arguments list. If there are remaining arguments, REG0 = T and the value is on the stack, otherwise REG0 = NIL. - */ - CASE(OP_POPOPT); { - if (frame_index >= frame->frame.size) { + */ + CASE(OP_POPOPT); { + if (frame_index >= frame->frame.size) { reg0 = ECL_NIL; } else { ECL_STACK_PUSH(the_env,frame->frame.base[frame_index++]); reg0 = ECL_T; } THREAD_NEXT; - } + } /* OP_NOMORE - No more arguments. + No more arguments. */ CASE(OP_NOMORE); { if (ecl_unlikely(frame_index < frame->frame.size)) too_many_arguments(bytecodes, frame); THREAD_NEXT; } - /* OP_POPREST - Makes a list out of the remaining arguments. - */ + /* OP_POPREST + Makes a list out of the remaining arguments. + */ CASE(OP_POPREST); { cl_object *first = frame->frame.base + frame_index; cl_object *last = frame->frame.base + frame->frame.size; @@ -595,10 +595,10 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } THREAD_NEXT; } - /* OP_PUSHKEYS {names-list} - Checks the stack frame for keyword arguments. - */ - CASE(OP_PUSHKEYS); { + /* OP_PUSHKEYS {names-list} + Checks the stack frame for keyword arguments. + */ + CASE(OP_PUSHKEYS); { cl_object keys_list, aok, *first, *last; cl_index count; GET_DATA(keys_list, vector, data); @@ -644,61 +644,61 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } THREAD_NEXT; } - /* OP_EXIT - Marks the end of a high level construct (BLOCK, CATCH...) - or a function. - */ - CASE(OP_EXIT); { - ecl_ihs_pop(the_env); - return reg0; - } - /* OP_FLET nfun{arg}, fun1{object} - ... - OP_UNBIND nfun - - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". Note that we only record the - index of the first function: the others are after this one. + /* OP_EXIT + Marks the end of a high level construct (BLOCK, CATCH...) + or a function. + */ + CASE(OP_EXIT); { + ecl_ihs_pop(the_env); + return reg0; + } + /* OP_FLET nfun{arg}, fun1{object} + ... + OP_UNBIND nfun + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". Note that we only record the + index of the first function: the others are after this one. Note that nfun > 0. - */ - CASE(OP_FLET); { - int nfun; - cl_object old_lex; - GET_OPARG(nfun, vector); - /* Copy the environment so that functions get it without references - to themselves, and then add new closures to the environment. */ - old_lex = lex_env; - do { - cl_object f; - GET_DATA(f, vector, data); - f = close_around(f, old_lex); - lex_env = bind_function(lex_env, f->bytecodes.name, f); - } while (--nfun); - THREAD_NEXT; - } - /* OP_LABELS nfun{arg} - fun1{object} - ... - funn{object} - ... - OP_UNBIND n + */ + CASE(OP_FLET); { + int nfun; + cl_object old_lex; + GET_OPARG(nfun, vector); + /* Copy the environment so that functions get it without references + to themselves, and then add new closures to the environment. */ + old_lex = lex_env; + do { + cl_object f; + GET_DATA(f, vector, data); + f = close_around(f, old_lex); + lex_env = bind_function(lex_env, f->bytecodes.name, f); + } while (--nfun); + THREAD_NEXT; + } + /* OP_LABELS nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_UNBIND n - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". - */ - CASE(OP_LABELS); { - cl_index nfun; - GET_OPARG(nfun, vector); - /* Build up a new environment with all functions */ + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". + */ + CASE(OP_LABELS); { + cl_index nfun; + GET_OPARG(nfun, vector); + /* Build up a new environment with all functions */ { cl_index i = nfun; do { cl_object f; - GET_DATA(f, vector, data); + GET_DATA(f, vector, data); lex_env = bind_function(lex_env, f->bytecodes.name, f); } while (--i); } - /* Update the closures so that all functions can call each other */ + /* Update the closures so that all functions can call each other */ { cl_object l = lex_env; do { @@ -706,572 +706,572 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) l = ECL_CONS_CDR(l); } while (--nfun); } - THREAD_NEXT; - } - /* OP_LFUNCTION n{arg}, function-name{symbol} - Calls the local or global function with N arguments - which have been deposited in the stack. - */ - CASE(OP_LFUNCTION); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); - THREAD_NEXT; - } + THREAD_NEXT; + } + /* OP_LFUNCTION n{arg}, function-name{symbol} + Calls the local or global function with N arguments + which have been deposited in the stack. + */ + CASE(OP_LFUNCTION); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); + THREAD_NEXT; + } - /* OP_FUNCTION name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - CASE(OP_FUNCTION); { - GET_DATA(reg0, vector, data); - reg0 = ecl_fdefinition(reg0); - THREAD_NEXT; - } + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + CASE(OP_FUNCTION); { + GET_DATA(reg0, vector, data); + reg0 = ecl_fdefinition(reg0); + THREAD_NEXT; + } - /* OP_CLOSE name{symbol} - Extracts the function associated to a symbol. The function - may be defined in the global environment or in the local - environment. This last value takes precedence. - */ - CASE(OP_CLOSE); { - GET_DATA(reg0, vector, data); - reg0 = close_around(reg0, lex_env); - THREAD_NEXT; - } - /* OP_GO n{arg}, tag-ndx{arg} - Jumps to the tag which is defined for the tagbody - frame registered at the n-th position in the lexical - environment. TAG-NDX is the number of tag in the list. - */ - CASE(OP_GO); { - cl_index lex_env_index; - cl_fixnum tag_ndx; - GET_OPARG(lex_env_index, vector); - GET_OPARG(tag_ndx, vector); - cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), - ecl_make_fixnum(tag_ndx)); - THREAD_NEXT; - } - /* OP_RETURN n{arg} - Returns from the block whose record in the lexical environment - occuppies the n-th position. - */ - CASE(OP_RETURN); { - int lex_env_index; - cl_object block_record; - GET_OPARG(lex_env_index, vector); - /* record = (id . name) */ - block_record = ecl_lex_env_get_record(lex_env, lex_env_index); - the_env->values[0] = reg0; - cl_return_from(ECL_CONS_CAR(block_record), - ECL_CONS_CDR(block_record)); - THREAD_NEXT; - } - /* OP_THROW - Jumps to an enclosing CATCH form whose tag matches the one - of the THROW. The tag is taken from the stack, while the - output values are left in VALUES(...). - */ - CASE(OP_THROW); { - cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); - the_env->values[0] = reg0; - cl_throw(tag_name); - THREAD_NEXT; - } - /* OP_JMP label{arg} - OP_JNIL label{arg} - OP_JT label{arg} - OP_JEQ value{object}, label{arg} - OP_JNEQ value{object}, label{arg} - Direct or conditional jumps. The conditional jumps are made - comparing with the value of REG0. - */ - CASE(OP_JMP); { - cl_oparg jump; - GET_OPARG(jump, vector); - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JNIL); { - cl_oparg jump; - GET_OPARG(jump, vector); - if (Null(reg0)) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JT); { - cl_oparg jump; - GET_OPARG(jump, vector); - if (!Null(reg0)) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JEQL); { - cl_oparg value, jump; - GET_OPARG(value, vector); - GET_OPARG(jump, vector); - if (ecl_eql(reg0, data[value])) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } - CASE(OP_JNEQL); { - cl_oparg value, jump; - GET_OPARG(value, vector); - GET_OPARG(jump, vector); - if (!ecl_eql(reg0, data[value])) - vector += jump - OPARG_SIZE; - THREAD_NEXT; - } + /* OP_CLOSE name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + CASE(OP_CLOSE); { + GET_DATA(reg0, vector, data); + reg0 = close_around(reg0, lex_env); + THREAD_NEXT; + } + /* OP_GO n{arg}, tag-ndx{arg} + Jumps to the tag which is defined for the tagbody + frame registered at the n-th position in the lexical + environment. TAG-NDX is the number of tag in the list. + */ + CASE(OP_GO); { + cl_index lex_env_index; + cl_fixnum tag_ndx; + GET_OPARG(lex_env_index, vector); + GET_OPARG(tag_ndx, vector); + cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), + ecl_make_fixnum(tag_ndx)); + THREAD_NEXT; + } + /* OP_RETURN n{arg} + Returns from the block whose record in the lexical environment + occuppies the n-th position. + */ + CASE(OP_RETURN); { + int lex_env_index; + cl_object block_record; + GET_OPARG(lex_env_index, vector); + /* record = (id . name) */ + block_record = ecl_lex_env_get_record(lex_env, lex_env_index); + the_env->values[0] = reg0; + cl_return_from(ECL_CONS_CAR(block_record), + ECL_CONS_CDR(block_record)); + THREAD_NEXT; + } + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + CASE(OP_THROW); { + cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); + the_env->values[0] = reg0; + cl_throw(tag_name); + THREAD_NEXT; + } + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ value{object}, label{arg} + OP_JNEQ value{object}, label{arg} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of REG0. + */ + CASE(OP_JMP); { + cl_oparg jump; + GET_OPARG(jump, vector); + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JNIL); { + cl_oparg jump; + GET_OPARG(jump, vector); + if (Null(reg0)) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JT); { + cl_oparg jump; + GET_OPARG(jump, vector); + if (!Null(reg0)) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JEQL); { + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (ecl_eql(reg0, data[value])) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } + CASE(OP_JNEQL); { + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (!ecl_eql(reg0, data[value])) + vector += jump - OPARG_SIZE; + THREAD_NEXT; + } - CASE(OP_ENDP); - if (ecl_unlikely(!LISTP(reg0))) + CASE(OP_ENDP); + if (ecl_unlikely(!LISTP(reg0))) FEwrong_type_only_arg(@[endp], reg0, @[list]); - CASE(OP_NOT); { - reg0 = (reg0 == ECL_NIL)? ECL_T : ECL_NIL; - THREAD_NEXT; - } + CASE(OP_NOT); { + reg0 = (reg0 == ECL_NIL)? ECL_T : ECL_NIL; + THREAD_NEXT; + } - /* OP_UNBIND n{arg} - Undo "n" local bindings. - */ - CASE(OP_UNBIND); { - cl_oparg n; - GET_OPARG(n, vector); - while (n--) - lex_env = ECL_CONS_CDR(lex_env); - THREAD_NEXT; - } - /* OP_UNBINDS n{arg} - Undo "n" bindings of special variables. - */ - CASE(OP_UNBINDS); { - cl_oparg n; - GET_OPARG(n, vector); - ecl_bds_unwind_n(the_env, n); - THREAD_NEXT; - } - /* OP_BIND name{symbol} - OP_PBIND name{symbol} - OP_VBIND nvalue{arg}, name{symbol} - OP_BINDS name{symbol} - OP_PBINDS name{symbol} - OP_VBINDS nvalue{arg}, name{symbol} - Binds a lexical or special variable to the the - value of REG0, the first value of the stack (PBIND) or - to a given value in the values array. - */ - CASE(OP_BIND); { - cl_object var_name; - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, reg0); - THREAD_NEXT; - } - CASE(OP_PBIND); { - cl_object var_name; - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VBIND); { - cl_index n; - cl_object var_name; - GET_OPARG(n, vector); - GET_DATA(var_name, vector, data); - lex_env = bind_var(lex_env, var_name, - (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); - THREAD_NEXT; - } - CASE(OP_BINDS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, reg0); - THREAD_NEXT; - } - CASE(OP_PBINDS); { - cl_object var_name; - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VBINDS); { - cl_index n; - cl_object var_name; - GET_OPARG(n, vector); - GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, - (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); - THREAD_NEXT; - } - /* OP_SETQ n{arg} - OP_PSETQ n{arg} - OP_SETQS var-name{symbol} - OP_PSETQS var-name{symbol} - OP_VSETQ n{arg}, nvalue{arg} - OP_VSETQS var-name{symbol}, nvalue{arg} - Sets either the n-th local or a special variable VAR-NAME, - to either the value in REG0 (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]), or to a given - value from the multiple values array (OP_VSETQ[S]). Note - that NVALUE > 0 strictly. - */ - CASE(OP_SETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, reg0); - THREAD_NEXT; - } - CASE(OP_SETQS); { - cl_object var; - GET_DATA(var, vector, data); - /* INV: Not NIL, and of type t_symbol */ - if (ecl_unlikely(var->symbol.stype & ecl_stp_constant)) - FEassignment_to_constant(var); - ECL_SETQ(the_env, var, reg0); - THREAD_NEXT; - } - CASE(OP_PSETQ); { - int lex_env_index; - GET_OPARG(lex_env_index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, + /* OP_UNBIND n{arg} + Undo "n" local bindings. + */ + CASE(OP_UNBIND); { + cl_oparg n; + GET_OPARG(n, vector); + while (n--) + lex_env = ECL_CONS_CDR(lex_env); + THREAD_NEXT; + } + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + CASE(OP_UNBINDS); { + cl_oparg n; + GET_OPARG(n, vector); + ecl_bds_unwind_n(the_env, n); + THREAD_NEXT; + } + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_VBIND nvalue{arg}, name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + OP_VBINDS nvalue{arg}, name{symbol} + Binds a lexical or special variable to the the + value of REG0, the first value of the stack (PBIND) or + to a given value in the values array. + */ + CASE(OP_BIND); { + cl_object var_name; + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, reg0); + THREAD_NEXT; + } + CASE(OP_PBIND); { + cl_object var_name; + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VBIND); { + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); + THREAD_NEXT; + } + CASE(OP_BINDS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, reg0); + THREAD_NEXT; + } + CASE(OP_PBINDS); { + cl_object var_name; + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VBINDS); { + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + ecl_bds_bind(the_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : ECL_NIL); + THREAD_NEXT; + } + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + OP_VSETQ n{arg}, nvalue{arg} + OP_VSETQS var-name{symbol}, nvalue{arg} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in REG0 (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]), or to a given + value from the multiple values array (OP_VSETQ[S]). Note + that NVALUE > 0 strictly. + */ + CASE(OP_SETQ); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, reg0); + THREAD_NEXT; + } + CASE(OP_SETQS); { + cl_object var; + GET_DATA(var, vector, data); + /* INV: Not NIL, and of type t_symbol */ + if (ecl_unlikely(var->symbol.stype & ecl_stp_constant)) + FEassignment_to_constant(var); + ECL_SETQ(the_env, var, reg0); + THREAD_NEXT; + } + CASE(OP_PSETQ); { + int lex_env_index; + GET_OPARG(lex_env_index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_PSETQS); { - cl_object var; - GET_DATA(var, vector, data); - /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); - THREAD_NEXT; - } - CASE(OP_VSETQ); { - cl_index lex_env_index; - cl_oparg index; - GET_OPARG(lex_env_index, vector); - GET_OPARG(index, vector); - ecl_lex_env_set_var(lex_env, lex_env_index, - (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]); - THREAD_NEXT; - } - CASE(OP_VSETQS); { - cl_object var, v; - cl_oparg index; - GET_DATA(var, vector, data); - GET_OPARG(index, vector); - v = (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]; - ECL_SETQ(the_env, var, v); - THREAD_NEXT; - } - - /* OP_BLOCK constant - OP_DO - OP_CATCH + THREAD_NEXT; + } + CASE(OP_PSETQS); { + cl_object var; + GET_DATA(var, vector, data); + /* INV: Not NIL, and of type t_symbol */ + ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); + THREAD_NEXT; + } + CASE(OP_VSETQ); { + cl_index lex_env_index; + cl_oparg index; + GET_OPARG(lex_env_index, vector); + GET_OPARG(index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, + (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]); + THREAD_NEXT; + } + CASE(OP_VSETQS); { + cl_object var, v; + cl_oparg index; + GET_DATA(var, vector, data); + GET_OPARG(index, vector); + v = (index >= the_env->nvalues)? ECL_NIL : the_env->values[index]; + ECL_SETQ(the_env, var, v); + THREAD_NEXT; + } + + /* OP_BLOCK constant + OP_DO + OP_CATCH - OP_FRAME label{arg} - ... - OP_EXIT_FRAME - label: - */ + OP_FRAME label{arg} + ... + OP_EXIT_FRAME + label: + */ - CASE(OP_BLOCK); { - GET_DATA(reg0, vector, data); - reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_DO); { - reg0 = ECL_NIL; - reg1 = ecl_make_fixnum(the_env->frame_id++); - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_CATCH); { - reg1 = reg0; - lex_env = bind_frame(lex_env, reg1, reg0); - THREAD_NEXT; - } - CASE(OP_FRAME); { - cl_opcode *exit; - GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)exit); - if (ecl_frs_push(the_env,reg1) == 0) { - THREAD_NEXT; - } else { - reg0 = the_env->values[0]; - vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ - lex_env = ECL_STACK_REF(the_env,-2); - goto DO_EXIT_FRAME; - } - } - /* OP_FRAMEID 0 - OP_TAGBODY n{arg} - label1 - ... - labeln - label1: - ... - labeln: - ... - OP_EXIT_TAGBODY + CASE(OP_BLOCK); { + GET_DATA(reg0, vector, data); + reg1 = ecl_make_fixnum(the_env->frame_id++); + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_DO); { + reg0 = ECL_NIL; + reg1 = ecl_make_fixnum(the_env->frame_id++); + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_CATCH); { + reg1 = reg0; + lex_env = bind_frame(lex_env, reg1, reg0); + THREAD_NEXT; + } + CASE(OP_FRAME); { + cl_opcode *exit; + GET_LABEL(exit, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)exit); + if (ecl_frs_push(the_env,reg1) == 0) { + THREAD_NEXT; + } else { + reg0 = the_env->values[0]; + vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ + lex_env = ECL_STACK_REF(the_env,-2); + goto DO_EXIT_FRAME; + } + } + /* OP_FRAMEID 0 + OP_TAGBODY n{arg} + label1 + ... + labeln + label1: + ... + labeln: + ... + OP_EXIT_TAGBODY - High level construct for the TAGBODY form. - */ - CASE(OP_TAGBODY); { - int n; - GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ - vector += n * OPARG_SIZE; - if (ecl_frs_push(the_env,reg1) != 0) { - /* Wait here for gotos. Each goto sets - VALUES(0) to an integer which ranges from 0 - to ntags-1, depending on the tag. These - numbers are indices into the jump table and - are computed at compile time. */ - cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); - lex_env = ECL_STACK_REF(the_env,-2); - table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; - vector = table + *(cl_oparg *)table; - } - THREAD_NEXT; - } - CASE(OP_EXIT_TAGBODY); { - reg0 = ECL_NIL; - } - CASE(OP_EXIT_FRAME); { - DO_EXIT_FRAME: - ecl_frs_pop(the_env); - ECL_STACK_POP_N_UNSAFE(the_env, 2); - lex_env = ECL_CONS_CDR(lex_env); - THREAD_NEXT; - } - CASE(OP_NIL); { - reg0 = ECL_NIL; - THREAD_NEXT; - } - CASE(OP_PUSHNIL); { - ECL_STACK_PUSH(the_env, ECL_NIL); - THREAD_NEXT; - } - CASE(OP_VALUEREG0); { - the_env->nvalues = 1; - THREAD_NEXT; - } + High level construct for the TAGBODY form. + */ + CASE(OP_TAGBODY); { + int n; + GET_OPARG(n, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ + vector += n * OPARG_SIZE; + if (ecl_frs_push(the_env,reg1) != 0) { + /* Wait here for gotos. Each goto sets + VALUES(0) to an integer which ranges from 0 + to ntags-1, depending on the tag. These + numbers are indices into the jump table and + are computed at compile time. */ + cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); + lex_env = ECL_STACK_REF(the_env,-2); + table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; + vector = table + *(cl_oparg *)table; + } + THREAD_NEXT; + } + CASE(OP_EXIT_TAGBODY); { + reg0 = ECL_NIL; + } + CASE(OP_EXIT_FRAME); { + DO_EXIT_FRAME: + ecl_frs_pop(the_env); + ECL_STACK_POP_N_UNSAFE(the_env, 2); + lex_env = ECL_CONS_CDR(lex_env); + THREAD_NEXT; + } + CASE(OP_NIL); { + reg0 = ECL_NIL; + THREAD_NEXT; + } + CASE(OP_PUSHNIL); { + ECL_STACK_PUSH(the_env, ECL_NIL); + THREAD_NEXT; + } + CASE(OP_VALUEREG0); { + the_env->nvalues = 1; + THREAD_NEXT; + } - /* OP_PUSHVALUES - Pushes the values output by the last form, plus the number - of values. - */ - PUSH_VALUES: - CASE(OP_PUSHVALUES); { - cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i+1); - the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); - THREAD_NEXT; - } - /* OP_PUSHMOREVALUES - Adds more values to the ones pushed by OP_PUSHVALUES. - */ - CASE(OP_PUSHMOREVALUES); { - cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); - cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i); - the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); - THREAD_NEXT; - } - /* OP_POPVALUES - Pops all values pushed by a OP_PUSHVALUES operator. - */ - CASE(OP_POPVALUES); { - cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (n == 0) { - *dest = reg0 = ECL_NIL; - THREAD_NEXT; - } else if (n == 1) { - *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); - THREAD_NEXT; - } else { - ECL_STACK_POP_N_UNSAFE(the_env,n); - memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); - reg0 = *dest; - THREAD_NEXT; - } - } - /* OP_VALUES n{arg} - Pop N values from the stack and store them in VALUES(...) - Note that N is strictly > 0. - */ - CASE(OP_VALUES); { - cl_fixnum n; - GET_OPARG(n, vector); - the_env->nvalues = n; - ECL_STACK_POP_N_UNSAFE(the_env, n); - memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - /* OP_NTHVAL - Set VALUES(0) to the N-th value of the VALUES(...) list. - The index N-th is extracted from the top of the stack. - */ - CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (ecl_unlikely(n < 0)) { - FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); - } else if ((cl_index)n >= the_env->nvalues) { - reg0 = ECL_NIL; - } else if (n) { - reg0 = the_env->values[n]; - } - THREAD_NEXT; - } - /* OP_PROTECT label - ... ; code to be protected and whose value is output - OP_PROTECT_NORMAL - label: - ... ; code executed at exit - OP_PROTECT_EXIT + /* OP_PUSHVALUES + Pushes the values output by the last form, plus the number + of values. + */ + PUSH_VALUES: + CASE(OP_PUSHVALUES); { + cl_index i = the_env->nvalues; + ECL_STACK_PUSH_N(the_env, i+1); + the_env->values[0] = reg0; + memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); + THREAD_NEXT; + } + /* OP_PUSHMOREVALUES + Adds more values to the ones pushed by OP_PUSHVALUES. + */ + CASE(OP_PUSHMOREVALUES); { + cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); + cl_index i = the_env->nvalues; + ECL_STACK_PUSH_N(the_env, i); + the_env->values[0] = reg0; + memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); + THREAD_NEXT; + } + /* OP_POPVALUES + Pops all values pushed by a OP_PUSHVALUES operator. + */ + CASE(OP_POPVALUES); { + cl_object *dest = the_env->values; + int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (n == 0) { + *dest = reg0 = ECL_NIL; + THREAD_NEXT; + } else if (n == 1) { + *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); + THREAD_NEXT; + } else { + ECL_STACK_POP_N_UNSAFE(the_env,n); + memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); + reg0 = *dest; + THREAD_NEXT; + } + } + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + Note that N is strictly > 0. + */ + CASE(OP_VALUES); { + cl_fixnum n; + GET_OPARG(n, vector); + the_env->nvalues = n; + ECL_STACK_POP_N_UNSAFE(the_env, n); + memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + CASE(OP_NTHVAL); { + cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (ecl_unlikely(n < 0)) { + FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); + } else if ((cl_index)n >= the_env->nvalues) { + reg0 = ECL_NIL; + } else if (n) { + reg0 = the_env->values[n]; + } + THREAD_NEXT; + } + /* OP_PROTECT label + ... ; code to be protected and whose value is output + OP_PROTECT_NORMAL + label: + ... ; code executed at exit + OP_PROTECT_EXIT - High level construct for UNWIND-PROTECT. The first piece of code is - executed and its output value is saved. Then the second piece of code - is executed and the output values restored. The second piece of code - is always executed, even if a THROW, RETURN or GO happen within the - first piece of code. - */ - CASE(OP_PROTECT); { - cl_opcode *exit; - GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, lex_env); - ECL_STACK_PUSH(the_env, (cl_object)exit); - if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) { - ecl_frs_pop(the_env); - vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); - reg0 = the_env->values[0]; - ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); - goto PUSH_VALUES; - } - THREAD_NEXT; - } - CASE(OP_PROTECT_NORMAL); { - ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); - ecl_frs_pop(the_env); - (void)ECL_STACK_POP_UNSAFE(the_env); - lex_env = ECL_STACK_POP_UNSAFE(the_env); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); - goto PUSH_VALUES; - } - CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - while (n--) - the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); - reg0 = the_env->values[0]; - n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - if (n <= 0) - ecl_unwind(the_env, the_env->frs_top + n); - THREAD_NEXT; - } + High level construct for UNWIND-PROTECT. The first piece of code is + executed and its output value is saved. Then the second piece of code + is executed and the output values restored. The second piece of code + is always executed, even if a THROW, RETURN or GO happen within the + first piece of code. + */ + CASE(OP_PROTECT); { + cl_opcode *exit; + GET_LABEL(exit, vector); + ECL_STACK_PUSH(the_env, lex_env); + ECL_STACK_PUSH(the_env, (cl_object)exit); + if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) { + ecl_frs_pop(the_env); + vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); + lex_env = ECL_STACK_POP_UNSAFE(the_env); + reg0 = the_env->values[0]; + ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); + goto PUSH_VALUES; + } + THREAD_NEXT; + } + CASE(OP_PROTECT_NORMAL); { + ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); + ecl_frs_pop(the_env); + (void)ECL_STACK_POP_UNSAFE(the_env); + lex_env = ECL_STACK_POP_UNSAFE(the_env); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); + goto PUSH_VALUES; + } + CASE(OP_PROTECT_EXIT); { + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + while (n--) + the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); + reg0 = the_env->values[0]; + n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + if (n <= 0) + ecl_unwind(the_env, the_env->frs_top + n); + THREAD_NEXT; + } - /* OP_PROGV bindings{list} - ... - OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). - */ - CASE(OP_PROGV); { - cl_object values = reg0; - cl_object vars = ECL_STACK_POP_UNSAFE(the_env); - cl_index n = ecl_progv(the_env, vars, values); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); - THREAD_NEXT; - } - CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - ecl_bds_unwind(the_env, n); - THREAD_NEXT; - } - CASE(OP_CSET); { + /* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). + */ + CASE(OP_PROGV); { + cl_object values = reg0; + cl_object vars = ECL_STACK_POP_UNSAFE(the_env); + cl_index n = ecl_progv(the_env, vars, values); + ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + THREAD_NEXT; + } + CASE(OP_EXIT_PROGV); { + cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + ecl_bds_unwind(the_env, n); + THREAD_NEXT; + } + CASE(OP_CSET); { cl_object *p; GET_DATA_PTR(p, vector, data); *p = reg0; - THREAD_NEXT; - } + THREAD_NEXT; + } - CASE(OP_STEPIN); { - cl_object form; - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); - cl_index n; - GET_DATA(form, vector, data); - SETUP_ENV(the_env); - the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We are stepping in, but must first ask the user - * what to do. */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - ECL_STACK_PUSH(the_env, form); - INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); - } else if (a != ECL_NIL) { - /* The user told us to step over. *step-level* contains - * an integer number that, when it becomes 0, means - * that we have finished stepping over. */ - ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); - } else { - /* We are not inside a STEP form. This should - * actually never happen. */ - } - ecl_stack_pop_values(the_env, n); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - CASE(OP_STEPCALL); { - /* We are going to call a function. However, we would - * like to step _in_ the function. STEPPER takes care of - * that. */ - cl_fixnum n; - GET_OPARG(n, vector); - SETUP_ENV(the_env); - if (ECL_SYM_VAL(the_env, @'si::*step-action*') == ECL_T) { - ECL_STACK_PUSH(the_env, reg0); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); - } - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); - } - CASE(OP_STEPOUT); { - cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); - cl_index n; - SETUP_ENV(the_env); - the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); - if (a == ECL_T) { - /* We exit one stepping level */ - ECL_SETQ(the_env, @'si::*step-level*', - cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); - } else if (a == ecl_make_fixnum(0)) { - /* We are back to the level in which the user - * selected to step over. */ - ECL_SETQ(the_env, @'si::*step-action*', ECL_T); - } else if (a != ECL_NIL) { - ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); - } else { - /* Not stepping, nothing to be done. */ - } - ecl_stack_pop_values(the_env, n); - reg0 = the_env->values[0]; - THREAD_NEXT; - } - } + CASE(OP_STEPIN); { + cl_object form; + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); + cl_index n; + GET_DATA(form, vector, data); + SETUP_ENV(the_env); + the_env->values[0] = reg0; + n = ecl_stack_push_values(the_env); + if (a == ECL_T) { + /* We are stepping in, but must first ask the user + * what to do. */ + ECL_SETQ(the_env, @'si::*step-level*', + cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); + ECL_STACK_PUSH(the_env, form); + INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); + } else if (a != ECL_NIL) { + /* The user told us to step over. *step-level* contains + * an integer number that, when it becomes 0, means + * that we have finished stepping over. */ + ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); + } else { + /* We are not inside a STEP form. This should + * actually never happen. */ + } + ecl_stack_pop_values(the_env, n); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + CASE(OP_STEPCALL); { + /* We are going to call a function. However, we would + * like to step _in_ the function. STEPPER takes care of + * that. */ + cl_fixnum n; + GET_OPARG(n, vector); + SETUP_ENV(the_env); + if (ECL_SYM_VAL(the_env, @'si::*step-action*') == ECL_T) { + ECL_STACK_PUSH(the_env, reg0); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); + } + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); + } + CASE(OP_STEPOUT); { + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); + cl_index n; + SETUP_ENV(the_env); + the_env->values[0] = reg0; + n = ecl_stack_push_values(the_env); + if (a == ECL_T) { + /* We exit one stepping level */ + ECL_SETQ(the_env, @'si::*step-level*', + cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); + } else if (a == ecl_make_fixnum(0)) { + /* We are back to the level in which the user + * selected to step over. */ + ECL_SETQ(the_env, @'si::*step-action*', ECL_T); + } else if (a != ECL_NIL) { + ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); + } else { + /* Not stepping, nothing to be done. */ + } + ecl_stack_pop_values(the_env, n); + reg0 = the_env->values[0]; + THREAD_NEXT; + } + } } @(defun si::interpreter-stack () @ - @(return ECL_NIL) + @(return ECL_NIL) @) diff --git a/src/c/iso_latin_names.h b/src/c/iso_latin_names.h index 8136578b0..fa1a1ec34 100644 --- a/src/c/iso_latin_names.h +++ b/src/c/iso_latin_names.h @@ -151,20 +151,20 @@ ecl_def_string_array(char_names,static,const) = { * the other codes. */ ecl_def_string_array(extra_char_names,static,const) = { ecl_def_string_array_elt("Null"), /* 0 */ - ecl_def_string_array_elt("Bell"), /* 7 */ - ecl_def_string_array_elt("Bs"), /* 8 */ - ecl_def_string_array_elt("Ht"), /* 9 */ - ecl_def_string_array_elt("Linefeed"), /* 10 */ - ecl_def_string_array_elt("Lf"), /* 10 */ - ecl_def_string_array_elt("Escape"), /* 27 */ - ecl_def_string_array_elt("Ff"), /* 12 */ - ecl_def_string_array_elt("Cr"), /* 13 */ - ecl_def_string_array_elt("Sp"), /* 32 */ - ecl_def_string_array_elt("Del") /* 127 */ + ecl_def_string_array_elt("Bell"), /* 7 */ + ecl_def_string_array_elt("Bs"), /* 8 */ + ecl_def_string_array_elt("Ht"), /* 9 */ + ecl_def_string_array_elt("Linefeed"), /* 10 */ + ecl_def_string_array_elt("Lf"), /* 10 */ + ecl_def_string_array_elt("Escape"), /* 27 */ + ecl_def_string_array_elt("Ff"), /* 12 */ + ecl_def_string_array_elt("Cr"), /* 13 */ + ecl_def_string_array_elt("Sp"), /* 32 */ + ecl_def_string_array_elt("Del") /* 127 */ }; static const unsigned char extra_char_codes[] = { - 0, 7, 8, 9, 10, 10, 27, 12, 13, 32, 127 + 0, 7, 8, 9, 10, 10, 27, 12, 13, 32, 127 }; #define extra_char_names_size 11 diff --git a/src/c/list.d b/src/c/list.d index 2ad9eda1e..9cffe5074 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -19,14 +19,14 @@ #include struct cl_test { - bool (*test_c_function)(struct cl_test *, cl_object); - cl_object (*key_c_function)(struct cl_test *, cl_object); - cl_env_ptr env; - cl_object key_function; - cl_objectfn key_fn; - cl_object test_function; - cl_objectfn test_fn; - cl_object item_compared; + bool (*test_c_function)(struct cl_test *, cl_object); + cl_object (*key_c_function)(struct cl_test *, cl_object); + cl_env_ptr env; + cl_object key_function; + cl_objectfn key_fn; + cl_object test_function; + cl_objectfn test_fn; + cl_object item_compared; }; static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree); @@ -42,153 +42,153 @@ static cl_object do_assoc(struct cl_test *t, cl_object alist); static bool test_compare(struct cl_test *t, cl_object x) { - x = KEY(t,x); - t->env->function = t->test_function; - return t->test_fn(2, t->item_compared, x) != ECL_NIL; + x = KEY(t,x); + t->env->function = t->test_function; + return t->test_fn(2, t->item_compared, x) != ECL_NIL; } static bool test_compare_not(struct cl_test *t, cl_object x) { - x = KEY(t,x); - t->env->function = t->test_function; - return t->test_fn(2, t->item_compared, x) == ECL_NIL; + x = KEY(t,x); + t->env->function = t->test_function; + return t->test_fn(2, t->item_compared, x) == ECL_NIL; } static bool test_eq(struct cl_test *t, cl_object x) { - return (t->item_compared == KEY(t,x)); + return (t->item_compared == KEY(t,x)); } static bool test_eql(struct cl_test *t, cl_object x) { - return ecl_eql(t->item_compared, KEY(t,x)); + return ecl_eql(t->item_compared, KEY(t,x)); } static bool test_equal(struct cl_test *t, cl_object x) { - return ecl_equal(t->item_compared, KEY(t,x)); + return ecl_equal(t->item_compared, KEY(t,x)); } static bool test_equalp(struct cl_test *t, cl_object x) { - return ecl_equalp(t->item_compared, KEY(t,x)); + return ecl_equalp(t->item_compared, KEY(t,x)); } static cl_object key_function(struct cl_test *t, cl_object x) { - t->env->function = t->key_function; - return t->key_fn(1,x); + t->env->function = t->key_function; + return t->key_fn(1,x); } static cl_object key_identity(struct cl_test *t, cl_object x) { - return x; + return x; } static void setup_test(struct cl_test *t, cl_object item, cl_object test, - cl_object test_not, cl_object key) + cl_object test_not, cl_object key) { - cl_env_ptr env = t->env = ecl_process_env(); - t->item_compared = item; - if (test != ECL_NIL) { - if (test_not != ECL_NIL) - FEerror("Both :TEST and :TEST-NOT are specified.", 0); - t->test_function = test = si_coerce_to_function(test); - if (test == ECL_SYM_FUN(@'eq')) { - t->test_c_function = test_eq; - } else if (test == ECL_SYM_FUN(@'eql')) { - t->test_c_function = test_eql; - } else if (test == ECL_SYM_FUN(@'equal')) { - t->test_c_function = test_equal; - } else if (test == ECL_SYM_FUN(@'equalp')) { - t->test_c_function = test_equalp; - } else { - t->test_c_function = test_compare; - t->test_fn = ecl_function_dispatch(env, test); - t->test_function = env->function; - } - } else if (test_not != ECL_NIL) { - t->test_c_function = test_compare_not; - test_not = si_coerce_to_function(test_not); - t->test_fn = ecl_function_dispatch(env, test_not); - t->test_function = env->function; - } else { - t->test_c_function = test_eql; - } - if (key != ECL_NIL) { - key = si_coerce_to_function(key); - t->key_fn = ecl_function_dispatch(env, key); - t->key_function = env->function; - t->key_c_function = key_function; - } else { - t->key_c_function = key_identity; - } + cl_env_ptr env = t->env = ecl_process_env(); + t->item_compared = item; + if (test != ECL_NIL) { + if (test_not != ECL_NIL) + FEerror("Both :TEST and :TEST-NOT are specified.", 0); + t->test_function = test = si_coerce_to_function(test); + if (test == ECL_SYM_FUN(@'eq')) { + t->test_c_function = test_eq; + } else if (test == ECL_SYM_FUN(@'eql')) { + t->test_c_function = test_eql; + } else if (test == ECL_SYM_FUN(@'equal')) { + t->test_c_function = test_equal; + } else if (test == ECL_SYM_FUN(@'equalp')) { + t->test_c_function = test_equalp; + } else { + t->test_c_function = test_compare; + t->test_fn = ecl_function_dispatch(env, test); + t->test_function = env->function; + } + } else if (test_not != ECL_NIL) { + t->test_c_function = test_compare_not; + test_not = si_coerce_to_function(test_not); + t->test_fn = ecl_function_dispatch(env, test_not); + t->test_function = env->function; + } else { + t->test_c_function = test_eql; + } + if (key != ECL_NIL) { + key = si_coerce_to_function(key); + t->key_fn = ecl_function_dispatch(env, key); + t->key_function = env->function; + t->key_c_function = key_function; + } else { + t->key_c_function = key_identity; + } } @(defun list (&rest args) - cl_object head = ECL_NIL; + cl_object head = ECL_NIL; @ - if (narg--) { - cl_object tail = head = ecl_list1(ecl_va_arg(args)); - while (narg--) { - cl_object cons = ecl_list1(ecl_va_arg(args)); - ECL_RPLACD(tail, cons); - tail = cons; - } - } - @(return head) + if (narg--) { + cl_object tail = head = ecl_list1(ecl_va_arg(args)); + while (narg--) { + cl_object cons = ecl_list1(ecl_va_arg(args)); + ECL_RPLACD(tail, cons); + tail = cons; + } + } + @(return head) @) @(defun list* (&rest args) - cl_object head; + cl_object head; @ - if (narg == 0) - FEwrong_num_arguments(@[list*]); - head = ecl_va_arg(args); - if (--narg) { - cl_object tail = head = ecl_list1(head); - while (--narg) { - cl_object cons = ecl_list1(ecl_va_arg(args)); - ECL_RPLACD(tail, cons); - tail = cons; - } - ECL_RPLACD(tail, ecl_va_arg(args)); - } - @(return head) + if (narg == 0) + FEwrong_num_arguments(@[list*]); + head = ecl_va_arg(args); + if (--narg) { + cl_object tail = head = ecl_list1(head); + while (--narg) { + cl_object cons = ecl_list1(ecl_va_arg(args)); + ECL_RPLACD(tail, cons); + tail = cons; + } + ECL_RPLACD(tail, ecl_va_arg(args)); + } + @(return head) @) static cl_object * append_into(cl_object head, cl_object *tail, cl_object l) { - if (!Null(*tail)) { - /* (APPEND '(1 . 2) 3) */ - FEtype_error_proper_list(head); - } - while (CONSP(l)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - *tail = cons; - tail = &ECL_CONS_CDR(cons); - l = ECL_CONS_CDR(l); - } + if (!Null(*tail)) { + /* (APPEND '(1 . 2) 3) */ + FEtype_error_proper_list(head); + } + while (CONSP(l)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + *tail = cons; + tail = &ECL_CONS_CDR(cons); + l = ECL_CONS_CDR(l); + } *tail = l; - return tail; + return tail; } @(defun append (&rest rest) - cl_object head = ECL_NIL, *tail = &head; + cl_object head = ECL_NIL, *tail = &head; @ - for (; narg > 1; narg--) { - cl_object other = ecl_va_arg(rest); + for (; narg > 1; narg--) { + cl_object other = ecl_va_arg(rest); tail = append_into(head, tail, other); - } + } if (narg) { if (!Null(*tail)) { /* (APPEND '(1 . 2) 3) */ @@ -196,15 +196,15 @@ append_into(cl_object head, cl_object *tail, cl_object l) } *tail = ecl_va_arg(rest); } - @(return head) + @(return head) @) cl_object ecl_append(cl_object x, cl_object y) { - cl_object head = ECL_NIL; + cl_object head = ECL_NIL; cl_object *tail = &head; - if (!Null(x)) { + if (!Null(x)) { tail = append_into(head, tail, x); } if (!Null(*tail)) { @@ -212,61 +212,61 @@ ecl_append(cl_object x, cl_object y) FEtype_error_proper_list(head); } *tail = y; - return head; + return head; } -#define LENTH(n) (cl_object x) { \ - const cl_env_ptr the_env = ecl_process_env(); \ - ecl_return1(the_env, ecl_nth(n, x)); \ - } -cl_object @fifth LENTH(4) -cl_object @sixth LENTH(5) -cl_object @seventh LENTH(6) -cl_object @eighth LENTH(7) -cl_object @ninth LENTH(8) -cl_object @tenth LENTH(9) +#define LENTH(n) (cl_object x) { \ + const cl_env_ptr the_env = ecl_process_env(); \ + ecl_return1(the_env, ecl_nth(n, x)); \ + } +cl_object @fifth LENTH(4) +cl_object @sixth LENTH(5) +cl_object @seventh LENTH(6) +cl_object @eighth LENTH(7) +cl_object @ninth LENTH(8) +cl_object @tenth LENTH(9) #undef LENTH static bool tree_equal(struct cl_test *t, cl_object x, cl_object y) { BEGIN: - if (CONSP(x)) { - if (CONSP(y)) { - if (tree_equal(t, ECL_CONS_CAR(x), ECL_CONS_CAR(y))) { - x = ECL_CONS_CDR(x); - y = ECL_CONS_CDR(y); - goto BEGIN; - } else { - return(FALSE); - } - } else { - return(FALSE); - } - } else { - t->item_compared = x; - if (TEST(t, y)) - return(TRUE); - else - return(FALSE); - } + if (CONSP(x)) { + if (CONSP(y)) { + if (tree_equal(t, ECL_CONS_CAR(x), ECL_CONS_CAR(y))) { + x = ECL_CONS_CDR(x); + y = ECL_CONS_CDR(y); + goto BEGIN; + } else { + return(FALSE); + } + } else { + return(FALSE); + } + } else { + t->item_compared = x; + if (TEST(t, y)) + return(TRUE); + else + return(FALSE); + } } @(defun tree_equal (x y &key test test_not) - struct cl_test t; - cl_object output; + struct cl_test t; + cl_object output; @ - setup_test(&t, ECL_NIL, test, test_not, ECL_NIL); - output = tree_equal(&t, x, y)? ECL_T : ECL_NIL; - close_test(&t); - @(return output) + setup_test(&t, ECL_NIL, test, test_not, ECL_NIL); + output = tree_equal(&t, x, y)? ECL_T : ECL_NIL; + close_test(&t); + @(return output) @) cl_object cl_endp(cl_object x) { cl_object output = ECL_NIL; - if (Null(x)) { + if (Null(x)) { output = ECL_T; } else if (ecl_unlikely(!LISTP(x))) { FEwrong_type_only_arg(@[endp], x, @[list]); @@ -277,7 +277,7 @@ cl_endp(cl_object x) bool ecl_endp(cl_object x) { - if (Null(x)) { + if (Null(x)) { return TRUE; } else if (ecl_unlikely(!LISTP(x))) { FEwrong_type_only_arg(@[endp], x, @[list]); @@ -288,358 +288,358 @@ ecl_endp(cl_object x) cl_object cl_list_length(cl_object x) { - cl_fixnum n; - cl_object fast, slow; - /* INV: A list's length always fits in a fixnum */ - fast = slow = x; - for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { - if (ecl_unlikely(!LISTP(fast))) { - FEtype_error_list(fast); - } - if (n & 1) { - /* Circular list? */ - if (slow == fast) @(return ECL_NIL); - slow = ECL_CONS_CDR(slow); - } - } - @(return ecl_make_fixnum(n)); + cl_fixnum n; + cl_object fast, slow; + /* INV: A list's length always fits in a fixnum */ + fast = slow = x; + for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { + if (ecl_unlikely(!LISTP(fast))) { + FEtype_error_list(fast); + } + if (n & 1) { + /* Circular list? */ + if (slow == fast) @(return ECL_NIL); + slow = ECL_CONS_CDR(slow); + } + } + @(return ecl_make_fixnum(n)); } cl_object si_proper_list_p(cl_object x) { - cl_fixnum n; - cl_object fast, slow, test = ECL_T; - /* INV: A list's length always fits in a fixnum */ - fast = slow = x; - for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { - if (!LISTP(fast)) { + cl_fixnum n; + cl_object fast, slow, test = ECL_T; + /* INV: A list's length always fits in a fixnum */ + fast = slow = x; + for (n = 0; !Null(fast); n++, fast = ECL_CONS_CDR(fast)) { + if (!LISTP(fast)) { test = ECL_NIL; break; - } - if (n & 1) { - /* Circular list? */ - if (slow == fast) { + } + if (n & 1) { + /* Circular list? */ + if (slow == fast) { test = ECL_NIL; break; } - slow = ECL_CONS_CDR(slow); - } - } - @(return test); + slow = ECL_CONS_CDR(slow); + } + } + @(return test); } cl_object cl_nth(cl_object n, cl_object x) { - @(return ecl_nth(ecl_to_size(n), x)) + @(return ecl_nth(ecl_to_size(n), x)) } cl_object ecl_nth(cl_fixnum n, cl_object x) { - if (n < 0) - FEtype_error_index(x, n); - /* INV: No need to check for circularity since we visit - at most `n' conses */ - for (; n > 0 && CONSP(x); n--) - x = ECL_CONS_CDR(x); - if (Null(x)) - return ECL_NIL; - if (!LISTP(x)) - FEtype_error_list(x); - return ECL_CONS_CAR(x); + if (n < 0) + FEtype_error_index(x, n); + /* INV: No need to check for circularity since we visit + at most `n' conses */ + for (; n > 0 && CONSP(x); n--) + x = ECL_CONS_CDR(x); + if (Null(x)) + return ECL_NIL; + if (!LISTP(x)) + FEtype_error_list(x); + return ECL_CONS_CAR(x); } cl_object cl_nthcdr(cl_object n, cl_object x) { - @(return ecl_nthcdr(ecl_to_size(n), x)) + @(return ecl_nthcdr(ecl_to_size(n), x)) } cl_object ecl_nthcdr(cl_fixnum n, cl_object x) { - if (n < 0) - FEtype_error_index(x, n); - while (n-- > 0 && !Null(x)) { - if (LISTP(x)) { - x = ECL_CONS_CDR(x); - } else { - FEtype_error_list(x); - } - } - return x; + if (n < 0) + FEtype_error_index(x, n); + while (n-- > 0 && !Null(x)) { + if (LISTP(x)) { + x = ECL_CONS_CDR(x); + } else { + FEtype_error_list(x); + } + } + return x; } cl_object ecl_last(cl_object l, cl_index n) { - /* The algorithm is very simple. We run over the list with - * two pointers, "l" and "r". The separation between both - * must be "n", so that when "l" finds no more conses, "r" - * contains the output. */ - cl_object r; - for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - /* If "l" has not moved, we have to ensure that it is a list */ - if (r == l) { - if (!LISTP(r)) FEtype_error_list(l); - while (CONSP(r)) { - r = ECL_CONS_CDR(r); - } - return r; - } else if (n == 0) { - while (CONSP(r)) { - r = ECL_CONS_CDR(r); - l = ECL_CONS_CDR(l); - } - return l; - } else { - return l; - } + /* The algorithm is very simple. We run over the list with + * two pointers, "l" and "r". The separation between both + * must be "n", so that when "l" finds no more conses, "r" + * contains the output. */ + cl_object r; + for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + /* If "l" has not moved, we have to ensure that it is a list */ + if (r == l) { + if (!LISTP(r)) FEtype_error_list(l); + while (CONSP(r)) { + r = ECL_CONS_CDR(r); + } + return r; + } else if (n == 0) { + while (CONSP(r)) { + r = ECL_CONS_CDR(r); + l = ECL_CONS_CDR(l); + } + return l; + } else { + return l; + } } @(defun last (l &optional (k ecl_make_fixnum(1))) @ - if (ecl_t_of(k) == t_bignum) - @(return l) - @(return ecl_last(l, ecl_to_size(k))) + if (ecl_t_of(k) == t_bignum) + @(return l) + @(return ecl_last(l, ecl_to_size(k))) @) @(defun make_list (size &key initial_element &aux x) - cl_fixnum i; + cl_fixnum i; @ - /* INV: ecl_to_size() signals a type-error if SIZE is not a integer >=0 */ - i = ecl_to_size(size); - while (i-- > 0) - x = CONS(initial_element, x); - @(return x) + /* INV: ecl_to_size() signals a type-error if SIZE is not a integer >=0 */ + i = ecl_to_size(size); + while (i-- > 0) + x = CONS(initial_element, x); + @(return x) @) cl_object cl_copy_list(cl_object x) { - cl_object copy; - if (ecl_unlikely(!LISTP(x))) { + cl_object copy; + if (ecl_unlikely(!LISTP(x))) { FEwrong_type_only_arg(@[copy-list], x, @[list]); - } - copy = ECL_NIL; - if (!Null(x)) { - cl_object tail = copy = ecl_list1(CAR(x)); - while (x = ECL_CONS_CDR(x), CONSP(x)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(x)); - ECL_RPLACD(tail, cons); - tail = cons; - } - ECL_RPLACD(tail, x); - } - @(return copy); + } + copy = ECL_NIL; + if (!Null(x)) { + cl_object tail = copy = ecl_list1(CAR(x)); + while (x = ECL_CONS_CDR(x), CONSP(x)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(x)); + ECL_RPLACD(tail, cons); + tail = cons; + } + ECL_RPLACD(tail, x); + } + @(return copy); } static cl_object duplicate_pairs(cl_object x) { - cl_object p = ECL_CONS_CAR(x); - if (CONSP(p)) - p = CONS(ECL_CONS_CAR(p), ECL_CONS_CDR(p)); - return ecl_list1(p); + cl_object p = ECL_CONS_CAR(x); + if (CONSP(p)) + p = CONS(ECL_CONS_CAR(p), ECL_CONS_CDR(p)); + return ecl_list1(p); } cl_object cl_copy_alist(cl_object x) { - cl_object copy; - if (ecl_unlikely(!LISTP(x))) { + cl_object copy; + if (ecl_unlikely(!LISTP(x))) { FEwrong_type_only_arg(@[copy-alist], x, @[list]); - } - copy = ECL_NIL; - if (!Null(x)) { - cl_object tail = copy = duplicate_pairs(x); - while (x = ECL_CONS_CDR(x), !Null(x)) { - if (!LISTP(x)) { - FEtype_error_list(x); - } else { - cl_object cons = duplicate_pairs(x); - tail = ECL_RPLACD(tail, cons); - tail = cons; - } - } - } - @(return copy); + } + copy = ECL_NIL; + if (!Null(x)) { + cl_object tail = copy = duplicate_pairs(x); + while (x = ECL_CONS_CDR(x), !Null(x)) { + if (!LISTP(x)) { + FEtype_error_list(x); + } else { + cl_object cons = duplicate_pairs(x); + tail = ECL_RPLACD(tail, cons); + tail = cons; + } + } + } + @(return copy); } static cl_object do_copy_tree(cl_object x) { - if (CONSP(x)) { - x = CONS(do_copy_tree(ECL_CONS_CAR(x)), - do_copy_tree(ECL_CONS_CDR(x))); - } - return x; + if (CONSP(x)) { + x = CONS(do_copy_tree(ECL_CONS_CAR(x)), + do_copy_tree(ECL_CONS_CDR(x))); + } + return x; } cl_object cl_copy_tree(cl_object x) { - @(return do_copy_tree(x)) + @(return do_copy_tree(x)) } cl_object cl_revappend(cl_object x, cl_object y) { - loop_for_in(x) { - y = CONS(ECL_CONS_CAR(x),y); - } end_loop_for_in; - @(return y) + loop_for_in(x) { + y = CONS(ECL_CONS_CAR(x),y); + } end_loop_for_in; + @(return y) } @(defun nconc (&rest lists) - cl_object head = ECL_NIL, tail = ECL_NIL; -@ - while (narg--) { - cl_object new_tail, other = ecl_va_arg(lists); - if (Null(other)) { - new_tail = tail; - } else if (CONSP(other)) { - new_tail = ecl_last(other, 1); - } else { - if (narg) FEtype_error_list(other); - new_tail = tail; - } - if (Null(head)) { - head = other; - } else { - ECL_RPLACD(tail, other); - } - tail = new_tail; - } - @(return head) + cl_object head = ECL_NIL, tail = ECL_NIL; +@ + while (narg--) { + cl_object new_tail, other = ecl_va_arg(lists); + if (Null(other)) { + new_tail = tail; + } else if (CONSP(other)) { + new_tail = ecl_last(other, 1); + } else { + if (narg) FEtype_error_list(other); + new_tail = tail; + } + if (Null(head)) { + head = other; + } else { + ECL_RPLACD(tail, other); + } + tail = new_tail; + } + @(return head) @) cl_object ecl_nconc(cl_object l, cl_object y) { - if (Null(l)) { - return y; - } else { - ECL_RPLACD(ecl_last(l, 1), y); - return l; - } + if (Null(l)) { + return y; + } else { + ECL_RPLACD(ecl_last(l, 1), y); + return l; + } } cl_object cl_nreconc(cl_object l, cl_object y) { - cl_object x, z; - /* INV: when a circular list is "reconc'ed", the pointer ends - up at the beginning of the original list, hence we need no - slow pointer */ - for (x = l; !Null(x); ) { + cl_object x, z; + /* INV: when a circular list is "reconc'ed", the pointer ends + up at the beginning of the original list, hence we need no + slow pointer */ + for (x = l; !Null(x); ) { if (!LISTP(x)) FEtype_error_list(x); - z = x; - x = ECL_CONS_CDR(x); - if (x == l) FEcircular_list(l); - ECL_RPLACD(z, y); - y = z; - } - @(return y) + z = x; + x = ECL_CONS_CDR(x); + if (x == l) FEcircular_list(l); + ECL_RPLACD(z, y); + y = z; + } + @(return y) } cl_object ecl_butlast(cl_object l, cl_index n) { - /* See LAST for details on this algorithm */ - cl_object r; - for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - if (Null(r)) { - return ECL_NIL; - } else if (!LISTP(r)) { - /* We reach here either because l is shorter than n conses, - * or because it is not a list */ - if (r == l) FEtype_error_list(r); - return ECL_NIL; - } else { - /* We reach here because l has at least n conses and - * thus we can take CAR(l) */ - cl_object head, tail; - head = tail = ecl_list1(CAR(l)); - while (l = ECL_CONS_CDR(l), r = ECL_CONS_CDR(r), CONSP(r)) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - ECL_RPLACD(tail, cons); - tail = cons; - } - return head; - } + /* See LAST for details on this algorithm */ + cl_object r; + for (r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + if (Null(r)) { + return ECL_NIL; + } else if (!LISTP(r)) { + /* We reach here either because l is shorter than n conses, + * or because it is not a list */ + if (r == l) FEtype_error_list(r); + return ECL_NIL; + } else { + /* We reach here because l has at least n conses and + * thus we can take CAR(l) */ + cl_object head, tail; + head = tail = ecl_list1(CAR(l)); + while (l = ECL_CONS_CDR(l), r = ECL_CONS_CDR(r), CONSP(r)) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + ECL_RPLACD(tail, cons); + tail = cons; + } + return head; + } } @(defun butlast (lis &optional (nn ecl_make_fixnum(1))) @ - /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ - if (ecl_t_of(nn) == t_bignum) - @(return ECL_NIL); - /* INV: ecl_to_size() signals a type-error if NN is not an integer >=0 */ - @(return ecl_butlast(lis, ecl_to_size(nn))) + /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ + if (ecl_t_of(nn) == t_bignum) + @(return ECL_NIL); + /* INV: ecl_to_size() signals a type-error if NN is not an integer >=0 */ + @(return ecl_butlast(lis, ecl_to_size(nn))) @) cl_object ecl_nbutlast(cl_object l, cl_index n) { - cl_object r; - if (ecl_unlikely(!LISTP(l))) + cl_object r; + if (ecl_unlikely(!LISTP(l))) FEwrong_type_only_arg(@[nbutlast], l, @[list]); - for (n++, r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) - ; - if (n == 0) { - cl_object tail = l; - while (CONSP(r)) { - tail = ECL_CONS_CDR(tail); - r = ECL_CONS_CDR(r); - } - ECL_RPLACD(tail, ECL_NIL); - return l; - } - return ECL_NIL; + for (n++, r = l; n && CONSP(r); n--, r = ECL_CONS_CDR(r)) + ; + if (n == 0) { + cl_object tail = l; + while (CONSP(r)) { + tail = ECL_CONS_CDR(tail); + r = ECL_CONS_CDR(r); + } + ECL_RPLACD(tail, ECL_NIL); + return l; + } + return ECL_NIL; } @(defun nbutlast (lis &optional (nn ecl_make_fixnum(1))) @ - /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ - if (ecl_t_of(nn) == t_bignum) - @(return ECL_NIL) - /* INV: ecl_to_size() signas a type-error if NN is not an integer >=0 */ - @(return ecl_nbutlast(lis, ecl_to_size(nn))) + /* INV: No list has more than MOST_POSITIVE_FIXNUM elements */ + if (ecl_t_of(nn) == t_bignum) + @(return ECL_NIL) + /* INV: ecl_to_size() signas a type-error if NN is not an integer >=0 */ + @(return ecl_nbutlast(lis, ecl_to_size(nn))) @) cl_object cl_ldiff(cl_object x, cl_object y) { - cl_object head = ECL_NIL; - if (ecl_unlikely(!LISTP(x))) { + cl_object head = ECL_NIL; + if (ecl_unlikely(!LISTP(x))) { FEwrong_type_only_arg(@[ldiff], x, @[list]); - } - /* Here we use that, if X or Y are CONS, then (EQL X Y) - * only when X == Y */ - if (!Null(x) && (x != y)) { - cl_object tail = head = ecl_list1(ECL_CONS_CAR(x)); - while (1) { - x = ECL_CONS_CDR(x); - if (!CONSP(x)) { - if (!ecl_eql(x, y)) { - ECL_RPLACD(tail, x); - } - break; - } else if (x == y) { - break; - } else { - cl_object cons = ecl_list1(ECL_CONS_CAR(x)); - ECL_RPLACD(tail, cons); - tail = cons; - } - } - } - @(return head) + } + /* Here we use that, if X or Y are CONS, then (EQL X Y) + * only when X == Y */ + if (!Null(x) && (x != y)) { + cl_object tail = head = ecl_list1(ECL_CONS_CAR(x)); + while (1) { + x = ECL_CONS_CDR(x); + if (!CONSP(x)) { + if (!ecl_eql(x, y)) { + ECL_RPLACD(tail, x); + } + break; + } else if (x == y) { + break; + } else { + cl_object cons = ecl_list1(ECL_CONS_CAR(x)); + ECL_RPLACD(tail, cons); + tail = cons; + } + } + } + @(return head) } cl_object @@ -647,8 +647,8 @@ cl_rplaca(cl_object x, cl_object v) { if (ecl_unlikely(!CONSP(x))) FEwrong_type_nth_arg(@[rplaca], 1, x, @[cons]); - ECL_RPLACA(x, v); - @(return x) + ECL_RPLACA(x, v); + @(return x) } cl_object @@ -656,346 +656,346 @@ cl_rplacd(cl_object x, cl_object v) { if (ecl_unlikely(!CONSP(x))) FEwrong_type_nth_arg(@[rplacd], 1, x, @[cons]); - ECL_RPLACD(x, v); - @(return x) + ECL_RPLACD(x, v); + @(return x) } @(defun subst (new_obj old_obj tree &key test test_not key) - struct cl_test t; - cl_object output; + struct cl_test t; + cl_object output; @ - setup_test(&t, old_obj, test, test_not, key); - output = subst(&t, new_obj, tree); - close_test(&t); - @(return output) + setup_test(&t, old_obj, test, test_not, key); + output = subst(&t, new_obj, tree); + close_test(&t); + @(return output) @) static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree) { - if (TEST(t, tree)) { - return new_obj; - } else if (ECL_ATOM(tree)) { - return tree; - } else { - cl_object head, tail = ECL_NIL; - do { - cl_object cons = subst(t, new_obj, ECL_CONS_CAR(tree)); - cons = ecl_cons(cons, tree = ECL_CONS_CDR(tree)); - if (Null(tail)) { - head = cons; - } else { - ECL_RPLACD(tail, cons); - } - tail = cons; - if (TEST(t, tree)) { - ECL_RPLACD(tail, new_obj); - return head; - } - } while (CONSP(tree)); - return head; - } + if (TEST(t, tree)) { + return new_obj; + } else if (ECL_ATOM(tree)) { + return tree; + } else { + cl_object head, tail = ECL_NIL; + do { + cl_object cons = subst(t, new_obj, ECL_CONS_CAR(tree)); + cons = ecl_cons(cons, tree = ECL_CONS_CDR(tree)); + if (Null(tail)) { + head = cons; + } else { + ECL_RPLACD(tail, cons); + } + tail = cons; + if (TEST(t, tree)) { + ECL_RPLACD(tail, new_obj); + return head; + } + } while (CONSP(tree)); + return head; + } } @(defun nsubst (new_obj old_obj tree &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, old_obj, test, test_not, key); - tree = nsubst(&t, new_obj, tree); - close_test(&t); - @(return tree) + setup_test(&t, old_obj, test, test_not, key); + tree = nsubst(&t, new_obj, tree); + close_test(&t); + @(return tree) @) static cl_object nsubst_cons(struct cl_test *t, cl_object new_obj, cl_object tree) { - cl_object l = tree; - do { - cl_object o = ECL_CONS_CAR(l); - if (TEST(t, o)) { - ECL_RPLACA(l, new_obj); - } else if (CONSP(o)) { - nsubst_cons(t, new_obj, o); - } - o = ECL_CONS_CDR(l); - if (TEST(t, o)) { - ECL_RPLACD(l, new_obj); - return tree; - } - l = o; - } while (CONSP(l)); - return tree; + cl_object l = tree; + do { + cl_object o = ECL_CONS_CAR(l); + if (TEST(t, o)) { + ECL_RPLACA(l, new_obj); + } else if (CONSP(o)) { + nsubst_cons(t, new_obj, o); + } + o = ECL_CONS_CDR(l); + if (TEST(t, o)) { + ECL_RPLACD(l, new_obj); + return tree; + } + l = o; + } while (CONSP(l)); + return tree; } static cl_object nsubst(struct cl_test *t, cl_object new_obj, cl_object tree) { - if (TEST(t, tree)) - return new_obj; - if (CONSP(tree)) - return nsubst_cons(t, new_obj, tree); - return tree; + if (TEST(t, tree)) + return new_obj; + if (CONSP(tree)) + return nsubst_cons(t, new_obj, tree); + return tree; } @(defun sublis (alist tree &key test test_not key) - /* t[0] is the test for the objects in the tree, configured - with test, test_not and key. t[1] is the test for searching - in the association list. - */ - struct cl_test t[2]; + /* t[0] is the test for the objects in the tree, configured + with test, test_not and key. t[1] is the test for searching + in the association list. + */ + struct cl_test t[2]; @ - setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); - setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); - tree = sublis(t, alist, tree); - close_test(t+1); - close_test(t); - @(return tree) + setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); + setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); + tree = sublis(t, alist, tree); + close_test(t+1); + close_test(t); + @(return tree) @) /* - Sublis(alist, tree) returns - result of substituting tree by alist. + Sublis(alist, tree) returns + result of substituting tree by alist. */ static cl_object sublis(struct cl_test *t, cl_object alist, cl_object tree) { - cl_object node; - t[1].item_compared = KEY(t, tree); - node = do_assoc(t+1, alist); - if (!Null(node)) { - return ECL_CONS_CDR(node); - } - if (CONSP(tree)) { - tree = CONS(sublis(t, alist, ECL_CONS_CAR(tree)), - sublis(t, alist, ECL_CONS_CDR(tree))); - } - return tree; + cl_object node; + t[1].item_compared = KEY(t, tree); + node = do_assoc(t+1, alist); + if (!Null(node)) { + return ECL_CONS_CDR(node); + } + if (CONSP(tree)) { + tree = CONS(sublis(t, alist, ECL_CONS_CAR(tree)), + sublis(t, alist, ECL_CONS_CDR(tree))); + } + return tree; } @(defun nsublis (alist tree &key test test_not key) - /* t[0] is the test for the objects in the tree, configured - with test, test_not and key. t[1] is the test for searching - in the association list. - */ - struct cl_test t[2]; + /* t[0] is the test for the objects in the tree, configured + with test, test_not and key. t[1] is the test for searching + in the association list. + */ + struct cl_test t[2]; @ - setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); - setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); - tree = nsublis(t, alist, tree); - close_test(t+1); - close_test(t); - @(return tree) + setup_test(t, ECL_NIL, ECL_NIL, ECL_NIL, key); + setup_test(t+1, ECL_NIL, test, test_not, ECL_NIL); + tree = nsublis(t, alist, tree); + close_test(t+1); + close_test(t); + @(return tree) @) /* - Nsublis(alist, treep) stores - the result of substiting *treep by alist - to *treep. + Nsublis(alist, treep) stores + the result of substiting *treep by alist + to *treep. */ static cl_object nsublis(struct cl_test *t, cl_object alist, cl_object tree) { - cl_object node; - t[1].item_compared = KEY(t, tree); - node = do_assoc(t+1, alist); - if (!Null(node)) { - return ECL_CONS_CDR(node); - } - if (CONSP(tree)) { - ECL_RPLACA(tree, nsublis(t, alist, ECL_CONS_CAR(tree))); - ECL_RPLACD(tree, nsublis(t, alist, ECL_CONS_CDR(tree))); - } - return tree; + cl_object node; + t[1].item_compared = KEY(t, tree); + node = do_assoc(t+1, alist); + if (!Null(node)) { + return ECL_CONS_CDR(node); + } + if (CONSP(tree)) { + ECL_RPLACA(tree, nsublis(t, alist, ECL_CONS_CAR(tree))); + ECL_RPLACD(tree, nsublis(t, alist, ECL_CONS_CDR(tree))); + } + return tree; } @(defun member (item list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - loop_for_in(list) { - if (TEST(&t, ECL_CONS_CAR(list))) - break; - } end_loop_for_in; - close_test(&t); - @(return list) + setup_test(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, ECL_CONS_CAR(list))) + break; + } end_loop_for_in; + close_test(&t); + @(return list) @) bool ecl_member_eq(cl_object x, cl_object l) { - loop_for_in(l) { - if (x == ECL_CONS_CAR(l)) - return(TRUE); - } end_loop_for_in; - return(FALSE); + loop_for_in(l) { + if (x == ECL_CONS_CAR(l)) + return(TRUE); + } end_loop_for_in; + return(FALSE); } cl_object si_memq(cl_object x, cl_object l) { - loop_for_in(l) { - if (x == ECL_CONS_CAR(l)) - @(return l) - } end_loop_for_in; - @(return ECL_NIL) + loop_for_in(l) { + if (x == ECL_CONS_CAR(l)) + @(return l) + } end_loop_for_in; + @(return ECL_NIL) } /* Added for use by the compiler, instead of open coding them. Beppe */ cl_object ecl_memql(cl_object x, cl_object l) { - loop_for_in(l) { - if (ecl_eql(x, ECL_CONS_CAR(l))) - return(l); - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + if (ecl_eql(x, ECL_CONS_CAR(l))) + return(l); + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_member(cl_object x, cl_object l) { - loop_for_in(l) { - if (ecl_equal(x, ECL_CONS_CAR(l))) - return(l); - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + if (ecl_equal(x, ECL_CONS_CAR(l))) + return(l); + } end_loop_for_in; + return(ECL_NIL); } /* End of addition. Beppe */ cl_object si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, cl_object key) { - struct cl_test t; + struct cl_test t; - if (key != ECL_NIL) - item = funcall(2, key, item); - setup_test(&t, item, test, test_not, key); - loop_for_in(list) { - if (TEST(&t, ECL_CONS_CAR(list))) - break; - } end_loop_for_in; - close_test(&t); - @(return list) + if (key != ECL_NIL) + item = funcall(2, key, item); + setup_test(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, ECL_CONS_CAR(list))) + break; + } end_loop_for_in; + close_test(&t); + @(return list) } cl_object cl_tailp(cl_object y, cl_object x) { - loop_for_on(x) { - if (ecl_eql(x, y)) @(return ECL_T); - } end_loop_for_on(x); - return cl_eql(x, y); + loop_for_on(x) { + if (ecl_eql(x, y)) @(return ECL_T); + } end_loop_for_on(x); + return cl_eql(x, y); } @(defun adjoin (item list &key test test_not key) - cl_object output; + cl_object output; @ - if (narg < 2) - FEwrong_num_arguments(@[adjoin]); - output = @si::member1(item, list, test, test_not, key); - if (Null(output)) - output = CONS(item, list); - else - output = list; - @(return output) + if (narg < 2) + FEwrong_num_arguments(@[adjoin]); + output = @si::member1(item, list, test, test_not, key); + if (Null(output)) + output = CONS(item, list); + else + output = list; + @(return output) @) cl_object cl_cons(cl_object x, cl_object y) { - @(return CONS(x, y)) + @(return CONS(x, y)) } cl_object cl_acons(cl_object x, cl_object y, cl_object z) { - @(return CONS(CONS(x, y), z)) + @(return CONS(CONS(x, y), z)) } @(defun pairlis (keys data &optional a_list) - cl_object k, d; + cl_object k, d; @ - k = keys; - d = data; - loop_for_in(k) { - if (ecl_endp(d)) - goto error; - a_list = CONS(CONS(ECL_CONS_CAR(k), ECL_CONS_CAR(d)), a_list); - d = CDR(d); - } end_loop_for_in; - if (!ecl_endp(d)) -error: FEerror("The keys ~S and the data ~S are not of the same length", - 2, keys, data); - @(return a_list) + k = keys; + d = data; + loop_for_in(k) { + if (ecl_endp(d)) + goto error; + a_list = CONS(CONS(ECL_CONS_CAR(k), ECL_CONS_CAR(d)), a_list); + d = CDR(d); + } end_loop_for_in; + if (!ecl_endp(d)) +error: FEerror("The keys ~S and the data ~S are not of the same length", + 2, keys, data); + @(return a_list) @) @(defun assoc (item a_list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - a_list = do_assoc(&t, a_list); - close_test(&t); - @(return a_list) + setup_test(&t, item, test, test_not, key); + a_list = do_assoc(&t, a_list); + close_test(&t); + @(return a_list) @) static cl_object do_assoc(struct cl_test *t, cl_object a_list) { - loop_for_in(a_list) { - cl_object pair = ECL_CONS_CAR(a_list); - if (!Null(pair)) { - if (!LISTP(pair)) - FEtype_error_list(pair); - if (TEST(t, ECL_CONS_CAR(pair))) - return pair; - } - } end_loop_for_in; - return ECL_NIL; + loop_for_in(a_list) { + cl_object pair = ECL_CONS_CAR(a_list); + if (!Null(pair)) { + if (!LISTP(pair)) + FEtype_error_list(pair); + if (TEST(t, ECL_CONS_CAR(pair))) + return pair; + } + } end_loop_for_in; + return ECL_NIL; } @(defun rassoc (item a_list &key test test_not key) - struct cl_test t; + struct cl_test t; @ - setup_test(&t, item, test, test_not, key); - loop_for_in(a_list) { - cl_object pair = ECL_CONS_CAR(a_list); - if (!Null(pair)) { - if (!LISTP(pair)) - FEtype_error_list(pair); - if (TEST(&t, ECL_CONS_CDR(pair))) { - a_list = pair; - break; - } - } - } end_loop_for_in; - close_test(&t); - @(return a_list) + setup_test(&t, item, test, test_not, key); + loop_for_in(a_list) { + cl_object pair = ECL_CONS_CAR(a_list); + if (!Null(pair)) { + if (!LISTP(pair)) + FEtype_error_list(pair); + if (TEST(&t, ECL_CONS_CDR(pair))) { + a_list = pair; + break; + } + } + } end_loop_for_in; + close_test(&t); + @(return a_list) @) cl_object ecl_remove_eq(cl_object x, cl_object l) { - cl_object head = ECL_NIL, tail = ECL_NIL; - loop_for_on_unsafe(l) { - if (ECL_CONS_CAR(l) != x) { - cl_object cons = ecl_list1(ECL_CONS_CAR(l)); - if (Null(tail)) { - head = tail = cons; - } else { - ECL_RPLACD(tail, cons); - tail = cons; - } - } - } end_loop_for_on_unsafe(l); - return head; + cl_object head = ECL_NIL, tail = ECL_NIL; + loop_for_on_unsafe(l) { + if (ECL_CONS_CAR(l) != x) { + cl_object cons = ecl_list1(ECL_CONS_CAR(l)); + if (Null(tail)) { + head = tail = cons; + } else { + ECL_RPLACD(tail, cons); + tail = cons; + } + } + } end_loop_for_on_unsafe(l); + return head; } cl_object ecl_delete_eq(cl_object x, cl_object l) { - cl_object head = l; + cl_object head = l; cl_object *p = &head; while (!ECL_ATOM(l)) { if (ECL_CONS_CAR(l) == x) { @@ -1005,51 +1005,51 @@ ecl_delete_eq(cl_object x, cl_object l) l = *p; } } - return head; + return head; } /* Added for use by the compiler, instead of open coding them. Beppe */ cl_object ecl_assq(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (x == CAR(pair)) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (x == CAR(pair)) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assql(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_eql(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_eql(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assoc(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_equal(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_equal(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } cl_object ecl_assqlp(cl_object x, cl_object l) { - loop_for_in(l) { - cl_object pair = ECL_CONS_CAR(l); - if (ecl_equalp(x, CAR(pair))) - return pair; - } end_loop_for_in; - return(ECL_NIL); + loop_for_in(l) { + cl_object pair = ECL_CONS_CAR(l); + if (ecl_equalp(x, CAR(pair))) + return pair; + } end_loop_for_in; + return(ECL_NIL); } /* End of addition. Beppe */ diff --git a/src/c/load.d b/src/c/load.d index c8c4492f3..754d2721b 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -23,33 +23,33 @@ cl_object si_load_binary(cl_object filename, cl_object verbose, cl_object print, cl_object external_format) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object block, map, array; - cl_object basename; - cl_object init_prefix, prefix; - cl_object output; + const cl_env_ptr the_env = ecl_process_env(); + cl_object block, map, array; + cl_object basename; + cl_object init_prefix, prefix; + cl_object output; - /* We need the full pathname */ - filename = cl_truename(filename); + /* We need the full pathname */ + filename = cl_truename(filename); - /* Try to load shared object file */ - block = ecl_library_open(filename, 1); - if (block->cblock.handle == NULL) { - output = ecl_library_error(block); - goto OUTPUT; - } + /* Try to load shared object file */ + block = ecl_library_open(filename, 1); + if (block->cblock.handle == NULL) { + output = ecl_library_error(block); + goto OUTPUT; + } - /* Fist try to call "init_CODE()" */ + /* Fist try to call "init_CODE()" */ init_prefix = _ecl_library_default_entry(); block->cblock.entry = ecl_library_symbol(block, (char *)init_prefix->base_string.self, 0); - if (block->cblock.entry != NULL) - goto GO_ON; + if (block->cblock.entry != NULL) + goto GO_ON; - /* Next try to call "init_FILE()" where FILE is the file name */ - prefix = ecl_symbol_value(@'si::*init-function-prefix*'); + /* Next try to call "init_FILE()" where FILE is the file name */ + prefix = ecl_symbol_value(@'si::*init-function-prefix*'); init_prefix = _ecl_library_init_prefix(); - if (Null(prefix)) { + if (Null(prefix)) { prefix = init_prefix; } else { prefix = @si::base-string-concatenate(3, @@ -57,52 +57,52 @@ si_load_binary(cl_object filename, cl_object verbose, prefix, make_constant_base_string("_")); } - basename = cl_pathname_name(1,filename); - basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', ECL_CODE_CHAR('_'), ECL_CODE_CHAR('-'), basename))); - block->cblock.entry = ecl_library_symbol(block, (char*)basename->base_string.self, 0); + basename = cl_pathname_name(1,filename); + basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', ECL_CODE_CHAR('_'), ECL_CODE_CHAR('-'), basename))); + block->cblock.entry = ecl_library_symbol(block, (char*)basename->base_string.self, 0); - if (block->cblock.entry == NULL) { - output = ecl_library_error(block); - ecl_library_close(block); - goto OUTPUT; - } + if (block->cblock.entry == NULL) { + output = ecl_library_error(block); + ecl_library_close(block); + goto OUTPUT; + } GO_ON: - /* Finally, perform initialization */ - ecl_init_module(block, (void (*)(cl_object))(block->cblock.entry)); - output = ECL_NIL; + /* Finally, perform initialization */ + ecl_init_module(block, (void (*)(cl_object))(block->cblock.entry)); + output = ECL_NIL; OUTPUT: - ecl_return1(the_env, output); + ecl_return1(the_env, output); } #endif /* !ENABLE_DLOPEN */ cl_object si_load_source(cl_object source, cl_object verbose, cl_object print, cl_object external_format) { - cl_env_ptr the_env = ecl_process_env(); - cl_object x, strm; + cl_env_ptr the_env = ecl_process_env(); + cl_object x, strm; - /* Source may be either a stream or a filename */ - if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { - /* INV: if "source" is not a valid stream, file.d will complain */ - strm = source; - } else { - strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, - ECL_STREAM_C_STREAM, external_format); - if (Null(strm)) - @(return ECL_NIL) - } - ECL_UNWIND_PROTECT_BEGIN(the_env) { - cl_object form_index = ecl_make_fixnum(0); + /* Source may be either a stream or a filename */ + if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { + /* INV: if "source" is not a valid stream, file.d will complain */ + strm = source; + } else { + strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, + ECL_STREAM_C_STREAM, external_format); + if (Null(strm)) + @(return ECL_NIL) + } + ECL_UNWIND_PROTECT_BEGIN(the_env) { + cl_object form_index = ecl_make_fixnum(0); cl_object pathname = ECL_SYM_VAL(the_env, @'*load-pathname*'); - cl_object location = CONS(pathname, form_index); - ecl_bds_bind(the_env, @'ext::*source-location*', location); - for (;;) { + cl_object location = CONS(pathname, form_index); + ecl_bds_bind(the_env, @'ext::*source-location*', location); + for (;;) { form_index = ecl_file_position(strm); ECL_RPLACD(location, form_index); - x = si_read_object_or_ignore(strm, OBJNULL); - if (x == OBJNULL) - break; + x = si_read_object_or_ignore(strm, OBJNULL); + if (x == OBJNULL) + break; if (the_env->nvalues) { si_eval_with_env(1, x); if (print != ECL_NIL) { @@ -110,38 +110,38 @@ si_load_source(cl_object source, cl_object verbose, cl_object print, cl_object e @terpri(0); } } - } - ecl_bds_unwind1(the_env); - } ECL_UNWIND_PROTECT_EXIT { - /* We do not want to come back here if close_stream fails, - therefore, first we frs_pop() current jump point, then - try to close the stream, and then jump to next catch - point */ - if (strm != source) - cl_close(3, strm, @':abort', @'t'); - } ECL_UNWIND_PROTECT_END; - @(return ECL_NIL) + } + ecl_bds_unwind1(the_env); + } ECL_UNWIND_PROTECT_EXIT { + /* We do not want to come back here if close_stream fails, + therefore, first we frs_pop() current jump point, then + try to close the stream, and then jump to next catch + point */ + if (strm != source) + cl_close(3, strm, @':abort', @'t'); + } ECL_UNWIND_PROTECT_END; + @(return ECL_NIL) } cl_object si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_object external_format) { - cl_env_ptr env = ecl_process_env(); - cl_object forms, strm; - cl_object old_eptbc = env->packages_to_be_created; + cl_env_ptr env = ecl_process_env(); + cl_object forms, strm; + cl_object old_eptbc = env->packages_to_be_created; - /* Source may be either a stream or a filename */ - if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { - /* INV: if "source" is not a valid stream, file.d will complain */ - strm = source; - } else { - strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, - ECL_STREAM_C_STREAM, external_format); - if (Null(strm)) - @(return ECL_NIL) - } - ECL_UNWIND_PROTECT_BEGIN(env) { + /* Source may be either a stream or a filename */ + if (ecl_t_of(source) != t_pathname && ecl_t_of(source) != t_base_string) { + /* INV: if "source" is not a valid stream, file.d will complain */ + strm = source; + } else { + strm = ecl_open_stream(source, ecl_smm_input, ECL_NIL, ECL_NIL, 8, + ECL_STREAM_C_STREAM, external_format); + if (Null(strm)) + @(return ECL_NIL) + } + ECL_UNWIND_PROTECT_BEGIN(env) { { cl_object progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); cl_index bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), @@ -170,133 +170,133 @@ si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_objec CEerror(ECL_T, Null(ECL_CONS_CDR(x))? "Package ~A referenced in " - "compiled file~& ~A~&but has not been created": + "compiled file~& ~A~&but has not been created": "The packages~& ~A~&were referenced in " - "compiled file~& ~A~&but have not been created", - 2, x, source); - } + "compiled file~& ~A~&but have not been created", + 2, x, source); } - } ECL_UNWIND_PROTECT_EXIT { - /* We do not want to come back here if close_stream fails, - therefore, first we frs_pop() current jump point, then - try to close the stream, and then jump to next catch - point */ - if (strm != source) - cl_close(3, strm, @':abort', @'t'); - } ECL_UNWIND_PROTECT_END; - @(return ECL_NIL) + } + } ECL_UNWIND_PROTECT_EXIT { + /* We do not want to come back here if close_stream fails, + therefore, first we frs_pop() current jump point, then + try to close the stream, and then jump to next catch + point */ + if (strm != source) + cl_close(3, strm, @':abort', @'t'); + } ECL_UNWIND_PROTECT_END; + @(return ECL_NIL) } @(defun load (source - &key (verbose ecl_symbol_value(@'*load-verbose*')) - (print ecl_symbol_value(@'*load-print*')) - (if_does_not_exist @':error') + &key (verbose ecl_symbol_value(@'*load-verbose*')) + (print ecl_symbol_value(@'*load-print*')) + (if_does_not_exist @':error') (external_format @':default') - (search_list ecl_symbol_value(@'si::*load-search-list*')) - &aux pathname pntype hooks filename function ok) - bool not_a_filename = 0; + (search_list ecl_symbol_value(@'si::*load-search-list*')) + &aux pathname pntype hooks filename function ok) + bool not_a_filename = 0; @ - /* If source is a stream, read conventional lisp code from it */ - if (ecl_t_of(source) != t_pathname && !ecl_stringp(source)) { - /* INV: if "source" is not a valid stream, file.d will complain */ - filename = source; - function = ECL_NIL; - not_a_filename = 1; - goto NOT_A_FILENAME; - } - /* INV: coerce_to_file_pathname() creates a fresh new pathname object */ - source = cl_merge_pathnames(1, source); - pathname = coerce_to_file_pathname(source); - pntype = pathname->pathname.type; + /* If source is a stream, read conventional lisp code from it */ + if (ecl_t_of(source) != t_pathname && !ecl_stringp(source)) { + /* INV: if "source" is not a valid stream, file.d will complain */ + filename = source; + function = ECL_NIL; + not_a_filename = 1; + goto NOT_A_FILENAME; + } + /* INV: coerce_to_file_pathname() creates a fresh new pathname object */ + source = cl_merge_pathnames(1, source); + pathname = coerce_to_file_pathname(source); + pntype = pathname->pathname.type; - filename = ECL_NIL; - hooks = ecl_symbol_value(@'ext::*load-hooks*'); - if (Null(pathname->pathname.directory) && - Null(pathname->pathname.host) && - Null(pathname->pathname.device) && - !Null(search_list)) - { - loop_for_in(search_list) { - cl_object d = CAR(search_list); - cl_object f = cl_merge_pathnames(2, pathname, d); - cl_object ok = cl_load(11, f, @':verbose', verbose, - @':print', print, - @':if-does-not-exist', ECL_NIL, + filename = ECL_NIL; + hooks = ecl_symbol_value(@'ext::*load-hooks*'); + if (Null(pathname->pathname.directory) && + Null(pathname->pathname.host) && + Null(pathname->pathname.device) && + !Null(search_list)) + { + loop_for_in(search_list) { + cl_object d = CAR(search_list); + cl_object f = cl_merge_pathnames(2, pathname, d); + cl_object ok = cl_load(11, f, @':verbose', verbose, + @':print', print, + @':if-does-not-exist', ECL_NIL, @':external-format', external_format, - @':search-list', ECL_NIL); - if (!Null(ok)) { - @(return ok); - } - } end_loop_for_in; - } - if (!Null(pntype) && (pntype != @':wild')) { - /* If filename already has an extension, make sure - that the file exists */ + @':search-list', ECL_NIL); + if (!Null(ok)) { + @(return ok); + } + } end_loop_for_in; + } + if (!Null(pntype) && (pntype != @':wild')) { + /* If filename already has an extension, make sure + that the file exists */ cl_object kind; - filename = si_coerce_to_filename(pathname); + filename = si_coerce_to_filename(pathname); kind = si_file_kind(filename, ECL_T); - if (kind != @':file' && kind != @':special') { - filename = ECL_NIL; - } else { - function = cl_cdr(ecl_assoc(pathname->pathname.type, hooks)); - } - } else loop_for_in(hooks) { - /* Otherwise try with known extensions until a matching - file is found */ + if (kind != @':file' && kind != @':special') { + filename = ECL_NIL; + } else { + function = cl_cdr(ecl_assoc(pathname->pathname.type, hooks)); + } + } else loop_for_in(hooks) { + /* Otherwise try with known extensions until a matching + file is found */ cl_object kind; - filename = pathname; - filename->pathname.type = CAAR(hooks); - function = CDAR(hooks); + filename = pathname; + filename->pathname.type = CAAR(hooks); + function = CDAR(hooks); kind = si_file_kind(filename, ECL_T); - if (kind == @':file' || kind == @':special') - break; - else - filename = ECL_NIL; - } end_loop_for_in; - if (Null(filename)) { - if (Null(if_does_not_exist)) - @(return ECL_NIL) - else - FEcannot_open(source); - } + if (kind == @':file' || kind == @':special') + break; + else + filename = ECL_NIL; + } end_loop_for_in; + if (Null(filename)) { + if (Null(if_does_not_exist)) + @(return ECL_NIL) + else + FEcannot_open(source); + } NOT_A_FILENAME: - if (verbose != ECL_NIL) { - cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), - filename); - } - ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); - ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); - ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); - ecl_bds_bind(the_env, @'*load-truename*', - not_a_filename? ECL_NIL : (filename = cl_truename(filename))); - if (!Null(function)) { - ok = funcall(5, function, filename, verbose, print, external_format); - } else { + if (verbose != ECL_NIL) { + cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), + filename); + } + ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); + ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); + ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? ECL_NIL : source); + ecl_bds_bind(the_env, @'*load-truename*', + not_a_filename? ECL_NIL : (filename = cl_truename(filename))); + if (!Null(function)) { + ok = funcall(5, function, filename, verbose, print, external_format); + } else { #if 0 /* defined(ENABLE_DLOPEN) && !defined(ECL_MS_WINDOWS_HOST)*/ - /* - * DISABLED BECAUSE OF SECURITY ISSUES! - * In systems where we can do this, we try to load the file - * as a binary. When it fails, we will revert to source - * loading below. Is this safe? Well, it depends on whether - * your op.sys. checks integrity of binary exectables or - * just loads _anything_. - */ - if (not_a_filename) { - ok = ECL_T; - } else { - ok = si_load_binary(filename, verbose, print); - } - if (!Null(ok)) + /* + * DISABLED BECAUSE OF SECURITY ISSUES! + * In systems where we can do this, we try to load the file + * as a binary. When it fails, we will revert to source + * loading below. Is this safe? Well, it depends on whether + * your op.sys. checks integrity of binary exectables or + * just loads _anything_. + */ + if (not_a_filename) { + ok = ECL_T; + } else { + ok = si_load_binary(filename, verbose, print); + } + if (!Null(ok)) #endif - ok = si_load_source(filename, verbose, print, external_format); - } - ecl_bds_unwind_n(the_env, 4); - if (!Null(ok)) - FEerror("LOAD: Could not load file ~S (Error: ~S)", - 2, filename, ok); - if (print != ECL_NIL) { - cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), - filename); - } - @(return filename) + ok = si_load_source(filename, verbose, print, external_format); + } + ecl_bds_unwind_n(the_env, 4); + if (!Null(ok)) + FEerror("LOAD: Could not load file ~S (Error: ~S)", + 2, filename, ok); + if (print != ECL_NIL) { + cl_format(3, ECL_T, make_constant_base_string("~&;;; Loading ~s~%"), + filename); + } + @(return filename) @) diff --git a/src/c/macros.d b/src/c/macros.d index 9102769ba..8c3b468e8 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -29,12 +29,12 @@ * variable definitions, and local function and macro definitions. The * structure is as follows: * - * env -> ( var-list . fun-list ) - * fun-list -> ( { definition | atomic-marker }* ) - * definition -> ( macro-name SI::MACRO { extra-data }* ) - * | ( function-name FUNCTION { extra-data }* ) - * | ( a-symbol anything { extra-data }* ) - * atomic-marker -> CB | LB + * env -> ( var-list . fun-list ) + * fun-list -> ( { definition | atomic-marker }* ) + * definition -> ( macro-name SI::MACRO { extra-data }* ) + * | ( function-name FUNCTION { extra-data }* ) + * | ( a-symbol anything { extra-data }* ) + * atomic-marker -> CB | LB * * The main difference between the bytecode and C compilers is on the extra * information. On the other hand, both environments are similar enough that @@ -45,145 +45,145 @@ static cl_object search_symbol_macro(cl_object name, cl_object env) { - for (env = CAR(env); env != ECL_NIL; env = CDR(env)) { - cl_object record = CAR(env); - if (CONSP(record) && CAR(record) == name) { - if (CADR(record) == @'si::symbol-macro') - return CADDR(record); - return ECL_NIL; - } - } - return si_get_sysprop(name, @'si::symbol-macro'); + for (env = CAR(env); env != ECL_NIL; env = CDR(env)) { + cl_object record = CAR(env); + if (CONSP(record) && CAR(record) == name) { + if (CADR(record) == @'si::symbol-macro') + return CADDR(record); + return ECL_NIL; + } + } + return si_get_sysprop(name, @'si::symbol-macro'); } static cl_object search_macro_function(cl_object name, cl_object env) { - int type = ecl_symbol_type(name); - if (env != ECL_NIL) { - /* When the environment has been produced by the - compiler, there might be atoms/symbols signalling - closure and block boundaries. */ - while (!Null(env = CDR(env))) { - cl_object record = CAR(env); - if (CONSP(record) && CAR(record) == name) { - cl_object tag = CADR(record); - if (tag == @'si::macro') - return CADDR(record); - if (tag == @'function') - return ECL_NIL; - break; - } - } - } - if (type & ecl_stp_macro) { - return ECL_SYM_FUN(name); - } else { - return ECL_NIL; - } + int type = ecl_symbol_type(name); + if (env != ECL_NIL) { + /* When the environment has been produced by the + compiler, there might be atoms/symbols signalling + closure and block boundaries. */ + while (!Null(env = CDR(env))) { + cl_object record = CAR(env); + if (CONSP(record) && CAR(record) == name) { + cl_object tag = CADR(record); + if (tag == @'si::macro') + return CADDR(record); + if (tag == @'function') + return ECL_NIL; + break; + } + } + } + if (type & ecl_stp_macro) { + return ECL_SYM_FUN(name); + } else { + return ECL_NIL; + } } @(defun macro_function (sym &optional env) @ - @(return (search_macro_function(sym, env))) + @(return (search_macro_function(sym, env))) @) /* - Analyze a form and expand it once if it is a macro form. - VALUES(0) contains either the expansion or the original form. - VALUES(1) is true when there was a macroexpansion. + Analyze a form and expand it once if it is a macro form. + VALUES(0) contains either the expansion or the original form. + VALUES(1) is true when there was a macroexpansion. */ @(defun macroexpand_1 (form &optional (env ECL_NIL)) - cl_object exp_fun = ECL_NIL; + cl_object exp_fun = ECL_NIL; @ - if (ECL_ATOM(form)) { - if (ECL_SYMBOLP(form)) - exp_fun = search_symbol_macro(form, env); - } else { - cl_object head = CAR(form); - if (ECL_SYMBOLP(head)) - exp_fun = search_macro_function(head, env); - } - if (!Null(exp_fun)) { - cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); - if (hook == @'funcall') - form = _ecl_funcall3(exp_fun, form, env); - else - form = _ecl_funcall4(hook, exp_fun, form, env); - } - @(return form exp_fun) + if (ECL_ATOM(form)) { + if (ECL_SYMBOLP(form)) + exp_fun = search_symbol_macro(form, env); + } else { + cl_object head = CAR(form); + if (ECL_SYMBOLP(head)) + exp_fun = search_macro_function(head, env); + } + if (!Null(exp_fun)) { + cl_object hook = ecl_symbol_value(@'*macroexpand-hook*'); + if (hook == @'funcall') + form = _ecl_funcall3(exp_fun, form, env); + else + form = _ecl_funcall4(hook, exp_fun, form, env); + } + @(return form exp_fun) @) /* - Expands a form as many times as possible and returns the - finally expanded form. + Expands a form as many times as possible and returns the + finally expanded form. */ @(defun macroexpand (form &optional env) - cl_object done, old_form; + cl_object done, old_form; @ - done = ECL_NIL; - do { - form = cl_macroexpand_1(2, old_form = form, env); - if (ecl_nth_value(the_env, 1) == ECL_NIL) { - break; - } else if (old_form == form) { - FEerror("Infinite loop when expanding macro form ~A", 1, old_form); - } else { - done = ECL_T; - } - } while (1); - @(return form done) + done = ECL_NIL; + do { + form = cl_macroexpand_1(2, old_form = form, env); + if (ecl_nth_value(the_env, 1) == ECL_NIL) { + break; + } else if (old_form == form) { + FEerror("Infinite loop when expanding macro form ~A", 1, old_form); + } else { + done = ECL_T; + } + } while (1); + @(return form done) @) static cl_object or_macro(cl_object whole, cl_object env) { - cl_object output = ECL_NIL; - whole = CDR(whole); - if (Null(whole)) /* (OR) => NIL */ - @(return ECL_NIL); - while (!Null(CDR(whole))) { - output = CONS(CONS(CAR(whole), ECL_NIL), output); - whole = CDR(whole); - } - if (Null(output)) /* (OR form1) => form1 */ - @(return CAR(whole)); - /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */ - output = CONS(cl_list(2, ECL_T, CAR(whole)), output); - @(return CONS(@'cond', cl_nreverse(output))) + cl_object output = ECL_NIL; + whole = CDR(whole); + if (Null(whole)) /* (OR) => NIL */ + @(return ECL_NIL); + while (!Null(CDR(whole))) { + output = CONS(CONS(CAR(whole), ECL_NIL), output); + whole = CDR(whole); + } + if (Null(output)) /* (OR form1) => form1 */ + @(return CAR(whole)); + /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */ + output = CONS(cl_list(2, ECL_T, CAR(whole)), output); + @(return CONS(@'cond', cl_nreverse(output))) } static cl_object expand_and(cl_object whole) { - if (Null(whole)) - return ECL_T; - if (Null(CDR(whole))) - return CAR(whole); - return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole))); + if (Null(whole)) + return ECL_T; + if (Null(CDR(whole))) + return CAR(whole); + return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole))); } static cl_object and_macro(cl_object whole, cl_object env) { - @(return expand_and(CDR(whole))) + @(return expand_and(CDR(whole))) } static cl_object when_macro(cl_object whole, cl_object env) { - cl_object args = CDR(whole); - if (ecl_unlikely(ecl_endp(args))) - FEprogram_error_noreturn("Syntax error: ~S.", 1, whole); - return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args))); + cl_object args = CDR(whole); + if (ecl_unlikely(ecl_endp(args))) + FEprogram_error_noreturn("Syntax error: ~S.", 1, whole); + return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args))); } void init_macros(void) { - ECL_SET(@'*macroexpand-hook*', @'funcall'); - ecl_def_c_macro(@'or', or_macro, 2); - ecl_def_c_macro(@'and', and_macro, 2); - ecl_def_c_macro(@'when', when_macro, 2); + ECL_SET(@'*macroexpand-hook*', @'funcall'); + ecl_def_c_macro(@'or', or_macro, 2); + ecl_def_c_macro(@'and', and_macro, 2); + ecl_def_c_macro(@'when', when_macro, 2); } diff --git a/src/c/main.d b/src/c/main.d index f2e7294bb..a2b99e738 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -64,40 +64,40 @@ static int ARGC; static char **ARGV; cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { #ifdef GBC_BOEHM_GENGC - 1, /* ECL_OPT_INCREMENTAL_GC */ + 1, /* ECL_OPT_INCREMENTAL_GC */ #else - 0, /* ECL_OPT_INCREMENTAL_GC */ + 0, /* ECL_OPT_INCREMENTAL_GC */ #endif - 1, /* ECL_OPT_TRAP_SIGSEGV */ - 1, /* ECL_OPT_TRAP_SIGFPE */ - 1, /* ECL_OPT_TRAP_SIGINT */ - 1, /* ECL_OPT_TRAP_SIGILL */ - 1, /* ECL_OPT_TRAP_SIGBUS */ - 1, /* ECL_OPT_TRAP_SIGPIPE */ - 1, /* ECL_OPT_TRAP_SIGCHLD */ - 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ - 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ - 0, /* ECL_OPT_BOOTED */ - 8192, /* ECL_OPT_BIND_STACK_SIZE */ - 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ - 2048, /* ECL_OPT_FRAME_STACK_SIZE */ - 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ - 32768, /* ECL_OPT_LISP_STACK_SIZE */ - 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ - 128*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SIZE */ - 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ - 1, /* ECL_OPT_SIGALTSTACK_SIZE */ + 1, /* ECL_OPT_TRAP_SIGSEGV */ + 1, /* ECL_OPT_TRAP_SIGFPE */ + 1, /* ECL_OPT_TRAP_SIGINT */ + 1, /* ECL_OPT_TRAP_SIGILL */ + 1, /* ECL_OPT_TRAP_SIGBUS */ + 1, /* ECL_OPT_TRAP_SIGPIPE */ + 1, /* ECL_OPT_TRAP_SIGCHLD */ + 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ + 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ + 0, /* ECL_OPT_BOOTED */ + 8192, /* ECL_OPT_BIND_STACK_SIZE */ + 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ + 2048, /* ECL_OPT_FRAME_STACK_SIZE */ + 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ + 32768, /* ECL_OPT_LISP_STACK_SIZE */ + 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ + 128*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SIZE */ + 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ + 1, /* ECL_OPT_SIGALTSTACK_SIZE */ #if ECL_FIXNUM_BITS <= 32 - 1024*1024*1024, /* ECL_OPT_HEAP_SIZE */ + 1024*1024*1024, /* ECL_OPT_HEAP_SIZE */ #else - 4024*1024*1024, /* ECL_OPT_HEAP_SIZE */ + 4024*1024*1024, /* ECL_OPT_HEAP_SIZE */ #endif - 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ - 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ - 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ - 0}; + 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ + 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ + 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ + 0}; #if !defined(GBC_BOEHM) static char stdin_buf[BUFSIZ]; @@ -107,46 +107,46 @@ static char stdout_buf[BUFSIZ]; cl_fixnum ecl_get_option(int option) { - if (option >= ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } + if (option >= ECL_OPT_LIMIT || option < 0) { + FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); + } return ecl_option_values[option]; } void ecl_set_option(int option, cl_fixnum value) { - if (option > ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } else { - if (option < ECL_OPT_BOOTED && - ecl_option_values[ECL_OPT_BOOTED]) { - FEerror("Cannot change option ~D while ECL is running", - 1, ecl_make_fixnum(option)); - } - ecl_option_values[option] = value; - } + if (option > ECL_OPT_LIMIT || option < 0) { + FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); + } else { + if (option < ECL_OPT_BOOTED && + ecl_option_values[ECL_OPT_BOOTED]) { + FEerror("Cannot change option ~D while ECL is running", + 1, ecl_make_fixnum(option)); + } + ecl_option_values[option] = value; + } } void ecl_init_env(cl_env_ptr env) { - env->c_env = NULL; + env->c_env = NULL; #if defined(ECL_THREADS) - env->cleanup = 0; + env->cleanup = 0; #else - env->own_process = ECL_NIL; + env->own_process = ECL_NIL; #endif - env->string_pool = ECL_NIL; + env->string_pool = ECL_NIL; - env->stack = NULL; - env->stack_top = NULL; - env->stack_limit = NULL; - env->stack_size = 0; - ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); + env->stack = NULL; + env->stack_top = NULL; + env->stack_limit = NULL; + env->stack_size = 0; + ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); #if !defined(ECL_CMU_FORMAT) - env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); + env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); #endif #ifdef HAVE_LIBFFI env->ffi_args_limit = 0; @@ -155,38 +155,38 @@ ecl_init_env(cl_env_ptr env) env->ffi_values_ptrs = 0; #endif #ifdef ECL_DYNAMIC_FFI - env->fficall = ecl_alloc(sizeof(struct ecl_fficall)); - ((struct ecl_fficall*)env->fficall)->registers = 0; + env->fficall = ecl_alloc(sizeof(struct ecl_fficall)); + ((struct ecl_fficall*)env->fficall)->registers = 0; #endif #ifdef CLOS /* Needs 128 elements for 64 entries to differentiate between EQL specializers and class specializers */ - env->method_cache = ecl_make_cache(128, 4096); - env->slot_cache = ecl_make_cache(3, 4096); + env->method_cache = ecl_make_cache(128, 4096); + env->slot_cache = ecl_make_cache(3, 4096); #endif env->pending_interrupt = ECL_NIL; - { - int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; - env->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); - } + { + int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; + env->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); + } - init_stacks(env); + init_stacks(env); { - int i; - for (i = 0; i < 3; i++) { + int i; + for (i = 0; i < 3; i++) { cl_object x = ecl_alloc_object(t_bignum); _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE); - env->big_register[i] = x; - } + env->big_register[i] = x; + } } env->trap_fpe_bits = 0; env->packages_to_be_created = ECL_NIL; env->packages_to_be_created_p = ECL_NIL; - env->fault_address = env; + env->fault_address = env; } void @@ -194,14 +194,14 @@ _ecl_dealloc_env(cl_env_ptr env) { /* * Environment cleanup. This is only required when the environment is - * allocated using mmap or some other method. We could do more, cleaning - * up stacks, etc, but we actually do not do it because that would need - * a lisp environment set up -- the allocator assumes one -- and we - * may have already cleaned up the value of ecl_process_env() + * allocated using mmap or some other method. We could do more, cleaning + * up stacks, etc, but we actually do not do it because that would need + * a lisp environment set up -- the allocator assumes one -- and we + * may have already cleaned up the value of ecl_process_env() */ #if defined(ECL_USE_MPROTECT) - if (munmap(env, sizeof(*env))) - ecl_internal_error("Unable to deallocate environment structure."); + if (munmap(env, sizeof(*env))) + ecl_internal_error("Unable to deallocate environment structure."); #else # if defined(ECL_USE_GUARD_PAGE) if (VirtualFree(env, sizeof(*env), MEM_RELEASE)) @@ -213,33 +213,33 @@ _ecl_dealloc_env(cl_env_ptr env) cl_env_ptr _ecl_alloc_env(cl_env_ptr parent) { - /* - * Allocates the lisp environment for a thread. Depending on which - * mechanism we use for detecting delayed signals, we may allocate - * the environment using mmap or the garbage collector. - */ - cl_env_ptr output; + /* + * Allocates the lisp environment for a thread. Depending on which + * mechanism we use for detecting delayed signals, we may allocate + * the environment using mmap or the garbage collector. + */ + cl_env_ptr output; #if defined(ECL_USE_MPROTECT) - output = mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); - if (output == MAP_FAILED) - ecl_internal_error("Unable to allocate environment structure."); + output = mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + if (output == MAP_FAILED) + ecl_internal_error("Unable to allocate environment structure."); #else # if defined(ECL_USE_GUARD_PAGE) - output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, - PAGE_READWRITE); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); + output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, + PAGE_READWRITE); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); # else - static struct cl_env_struct first_env; - if (!ecl_option_values[ECL_OPT_BOOTED]) { - /* We have not set up any environment. Hence, we cannot call ecl_alloc() - * because it will need to stop interrupts and currently we rely on - * the environment for that */ - output = ecl_alloc_unprotected(sizeof(*output)); - } else { - output = ecl_alloc(sizeof(*output)); - } + static struct cl_env_struct first_env; + if (!ecl_option_values[ECL_OPT_BOOTED]) { + /* We have not set up any environment. Hence, we cannot call ecl_alloc() + * because it will need to stop interrupts and currently we rely on + * the environment for that */ + output = ecl_alloc_unprotected(sizeof(*output)); + } else { + output = ecl_alloc(sizeof(*output)); + } # endif #endif { @@ -255,36 +255,36 @@ _ecl_alloc_env(cl_env_ptr parent) output->default_sigmask = cl_core.default_sigmask; } } - /* - * An uninitialized environment _always_ disables interrupts. They - * are activated later on by the thread entry point or init_unixint(). - */ - output->disable_interrupts = 1; - output->pending_interrupt = ECL_NIL; - output->signal_queue_spinlock = ECL_NIL; - return output; + /* + * An uninitialized environment _always_ disables interrupts. They + * are activated later on by the thread entry point or init_unixint(). + */ + output->disable_interrupts = 1; + output->pending_interrupt = ECL_NIL; + output->signal_queue_spinlock = ECL_NIL; + return output; } void cl_shutdown(void) { - if (ecl_option_values[ECL_OPT_BOOTED] > 0) { - cl_object l = ecl_symbol_value(@'si::*exit-hooks*'); - cl_object form = cl_list(2, @'funcall', ECL_NIL); - while (CONSP(l)) { - ecl_elt_set(form, 1, ECL_CONS_CAR(l)); - si_safe_eval(3, form, ECL_NIL, OBJNULL); - l = CDR(l); - ECL_SET(@'si::*exit-hooks*', l); - } + if (ecl_option_values[ECL_OPT_BOOTED] > 0) { + cl_object l = ecl_symbol_value(@'si::*exit-hooks*'); + cl_object form = cl_list(2, @'funcall', ECL_NIL); + while (CONSP(l)) { + ecl_elt_set(form, 1, ECL_CONS_CAR(l)); + si_safe_eval(3, form, ECL_NIL, OBJNULL); + l = CDR(l); + ECL_SET(@'si::*exit-hooks*', l); + } #ifdef ENABLE_DLOPEN - ecl_library_close_all(); + ecl_library_close_all(); #endif #ifdef TCP - ecl_tcp_close_all(); + ecl_tcp_close_all(); #endif - } - ecl_set_option(ECL_OPT_BOOTED, -1); + } + ecl_set_option(ECL_OPT_BOOTED, -1); } ecl_def_ct_single_float(default_rehash_size,1.5f,static,const); @@ -350,98 +350,98 @@ ecl_def_ct_complex(flt_imag_unit_neg,&flt_zero_data,&flt_one_neg_data,static,con ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const); struct cl_core_struct cl_core = { - ECL_NIL, /* packages */ - ECL_NIL, /* lisp_package */ - ECL_NIL, /* user_package */ - ECL_NIL, /* keyword_package */ - ECL_NIL, /* system_package */ + ECL_NIL, /* packages */ + ECL_NIL, /* lisp_package */ + ECL_NIL, /* user_package */ + ECL_NIL, /* keyword_package */ + ECL_NIL, /* system_package */ ECL_NIL, /* ext_package */ #ifdef CLOS - ECL_NIL, /* clos_package */ + ECL_NIL, /* clos_package */ # ifdef ECL_CLOS_STREAMS - ECL_NIL, /* gray_package */ + ECL_NIL, /* gray_package */ # endif #endif - ECL_NIL, /* mp_package */ + ECL_NIL, /* mp_package */ ECL_NIL, /* c_package */ ECL_NIL, /* ffi_package */ - ECL_NIL, /* pathname_translations */ + ECL_NIL, /* pathname_translations */ ECL_NIL, /* library_pathname */ - ECL_NIL, /* terminal_io */ - ECL_NIL, /* null_stream */ - ECL_NIL, /* standard_input */ - ECL_NIL, /* standard_output */ - ECL_NIL, /* error_output */ - ECL_NIL, /* standard_readtable */ - ECL_NIL, /* dispatch_reader */ - ECL_NIL, /* default_dispatch_macro */ + ECL_NIL, /* terminal_io */ + ECL_NIL, /* null_stream */ + ECL_NIL, /* standard_input */ + ECL_NIL, /* standard_output */ + ECL_NIL, /* error_output */ + ECL_NIL, /* standard_readtable */ + ECL_NIL, /* dispatch_reader */ + ECL_NIL, /* default_dispatch_macro */ - ECL_NIL, /* char_names */ - (cl_object)&str_empty_data, /* null_string */ + ECL_NIL, /* char_names */ + (cl_object)&str_empty_data, /* null_string */ - (cl_object)&plus_half_data, /* plus_half */ - (cl_object)&minus_half_data, /* minus_half */ - (cl_object)&flt_imag_unit_data, /* imag_unit */ - (cl_object)&flt_imag_unit_neg_data, /* minus_imag_unit */ - (cl_object)&flt_imag_two_data, /* imag_two */ - (cl_object)&flt_zero_data, /* singlefloat_zero */ - (cl_object)&dbl_zero_data, /* doublefloat_zero */ - (cl_object)&flt_zero_neg_data, /* singlefloat_minus_zero */ - (cl_object)&dbl_zero_neg_data, /* doublefloat_minus_zero */ + (cl_object)&plus_half_data, /* plus_half */ + (cl_object)&minus_half_data, /* minus_half */ + (cl_object)&flt_imag_unit_data, /* imag_unit */ + (cl_object)&flt_imag_unit_neg_data, /* minus_imag_unit */ + (cl_object)&flt_imag_two_data, /* imag_two */ + (cl_object)&flt_zero_data, /* singlefloat_zero */ + (cl_object)&dbl_zero_data, /* doublefloat_zero */ + (cl_object)&flt_zero_neg_data, /* singlefloat_minus_zero */ + (cl_object)&dbl_zero_neg_data, /* doublefloat_minus_zero */ #ifdef ECL_LONG_FLOAT - (cl_object)&ldbl_zero_data, /* longfloat_zero */ - (cl_object)&ldbl_zero_neg_data, /* longfloat_minus_zero */ + (cl_object)&ldbl_zero_data, /* longfloat_zero */ + (cl_object)&ldbl_zero_neg_data, /* longfloat_minus_zero */ #endif - (cl_object)&str_G_data, /* gensym_prefix */ - (cl_object)&str_T_data, /* gentemp_prefix */ - ecl_make_fixnum(0), /* gentemp_counter */ + (cl_object)&str_G_data, /* gensym_prefix */ + (cl_object)&str_T_data, /* gentemp_prefix */ + ecl_make_fixnum(0), /* gentemp_counter */ - ECL_NIL, /* Jan1st1970UT */ + ECL_NIL, /* Jan1st1970UT */ - ECL_NIL, /* system_properties */ - ECL_NIL, /* setf_definition */ + ECL_NIL, /* system_properties */ + ECL_NIL, /* setf_definition */ #ifdef ECL_THREADS - ECL_NIL, /* processes */ - ECL_NIL, /* processes_spinlock */ - ECL_NIL, /* global_lock */ + ECL_NIL, /* processes */ + ECL_NIL, /* processes_spinlock */ + ECL_NIL, /* global_lock */ ECL_NIL, /* error_lock */ ECL_NIL, /* global_env_lock */ #endif - /* LIBRARIES is an adjustable vector of objects. It behaves as - a vector of weak pointers thanks to the magic in - gbc.d/alloc_2.d */ - ECL_NIL, /* libraries */ + /* LIBRARIES is an adjustable vector of objects. It behaves as + a vector of weak pointers thanks to the magic in + gbc.d/alloc_2.d */ + ECL_NIL, /* libraries */ - 0, /* max_heap_size */ - ECL_NIL, /* bytes_consed */ - ECL_NIL, /* gc_counter */ - 0, /* gc_stats */ - 0, /* path_max */ + 0, /* max_heap_size */ + ECL_NIL, /* bytes_consed */ + ECL_NIL, /* gc_counter */ + 0, /* gc_stats */ + 0, /* path_max */ #ifdef GBC_BOEHM NULL, /* safety_region */ #endif - NULL, /* default_sigmask */ + NULL, /* default_sigmask */ 0, /* default_sigmask_bytes */ #ifdef ECL_THREADS 0, /* last_var_index */ ECL_NIL, /* reused_indices */ #endif - (cl_object)&str_slash_data, /* slash */ + (cl_object)&str_slash_data, /* slash */ - ECL_NIL, /* compiler_dispatch */ + ECL_NIL, /* compiler_dispatch */ (cl_object)&default_rehash_size_data, /* rehash_size */ (cl_object)&default_rehash_threshold_data, /* rehash_threshold */ ECL_NIL, /* external_processes */ ECL_NIL, /* external_processes_lock */ - ECL_NIL /* known_signals */ + ECL_NIL /* known_signals */ }; #if !defined(ECL_MS_WINDOWS_HOST) @@ -450,319 +450,319 @@ struct cl_core_struct cl_core = { static void maybe_fix_console_stream(cl_object stream) { - DWORD cp = GetConsoleCP(); - const char *encoding; - cl_object external_format; - int i; - static const struct { - int code; - const char *name; - } known_cp[] = { - {874, "WINDOWS-CP874"}, - {932, "WINDOWS-CP932"}, - {936, "WINDOWS-CP936"}, - {949, "WINDOWS-CP949"}, - {950, "WINDOWS-CP950"}, - {1200, "WINDOWS-CP1200"}, - {1201, "WINDOWS-CP1201"}, - {1250, "WINDOWS-CP1250"}, - {1251, "WINDOWS-CP1251"}, - {1252, "WINDOWS-CP1252"}, - {1253, "WINDOWS-CP1253"}, - {1254, "WINDOWS-CP1254"}, - {1255, "WINDOWS-CP1255"}, - {1256, "WINDOWS-CP1256"}, - {1257, "WINDOWS-CP1257"}, - {1258, "WINDOWS-CP1258"}, - {65001, "UTF8"}, - {0,"LATIN-1"} - }; - if (stream->stream.mode != ecl_smm_io_wcon) - return; - for (i = 0; known_cp[i].code && known_cp[i].code != cp; i++) - {} - external_format = cl_list(2, ecl_make_keyword(known_cp[i].name), - @':crlf'); - si_stream_external_format_set(stream, external_format); - stream->stream.eof_char = 26; + DWORD cp = GetConsoleCP(); + const char *encoding; + cl_object external_format; + int i; + static const struct { + int code; + const char *name; + } known_cp[] = { + {874, "WINDOWS-CP874"}, + {932, "WINDOWS-CP932"}, + {936, "WINDOWS-CP936"}, + {949, "WINDOWS-CP949"}, + {950, "WINDOWS-CP950"}, + {1200, "WINDOWS-CP1200"}, + {1201, "WINDOWS-CP1201"}, + {1250, "WINDOWS-CP1250"}, + {1251, "WINDOWS-CP1251"}, + {1252, "WINDOWS-CP1252"}, + {1253, "WINDOWS-CP1253"}, + {1254, "WINDOWS-CP1254"}, + {1255, "WINDOWS-CP1255"}, + {1256, "WINDOWS-CP1256"}, + {1257, "WINDOWS-CP1257"}, + {1258, "WINDOWS-CP1258"}, + {65001, "UTF8"}, + {0,"LATIN-1"} + }; + if (stream->stream.mode != ecl_smm_io_wcon) + return; + for (i = 0; known_cp[i].code && known_cp[i].code != cp; i++) + {} + external_format = cl_list(2, ecl_make_keyword(known_cp[i].name), + @':crlf'); + si_stream_external_format_set(stream, external_format); + stream->stream.eof_char = 26; } #endif int cl_boot(int argc, char **argv) { - cl_object aux; - cl_object features; - int i; - cl_env_ptr env; + cl_object aux; + cl_object features; + int i; + cl_env_ptr env; - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } - /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ + /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ #if !defined(GBC_BOEHM) - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); + setbuf(stdin, stdin_buf); + setbuf(stdout, stdout_buf); #endif - ARGC = argc; - ARGV = argv; - ecl_self = argv[0]; + ARGC = argc; + ARGV = argv; + ecl_self = argv[0]; - init_unixint(0); - init_alloc(); - GC_disable(); - env = _ecl_alloc_env(0); + init_unixint(0); + init_alloc(); + GC_disable(); + env = _ecl_alloc_env(0); #ifdef ECL_THREADS init_threads(env); #else - cl_env_p = env; + cl_env_p = env; #endif - /* - * 1) Initialize symbols and packages - */ + /* + * 1) Initialize symbols and packages + */ - ECL_NIL_SYMBOL->symbol.t = t_symbol; - ECL_NIL_SYMBOL->symbol.dynamic = 0; - ECL_NIL_SYMBOL->symbol.value = ECL_NIL; - ECL_NIL_SYMBOL->symbol.name = str_NIL; - ECL_NIL_SYMBOL->symbol.gfdef = ECL_NIL; - ECL_NIL_SYMBOL->symbol.plist = ECL_NIL; - ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; - ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; + ECL_NIL_SYMBOL->symbol.t = t_symbol; + ECL_NIL_SYMBOL->symbol.dynamic = 0; + ECL_NIL_SYMBOL->symbol.value = ECL_NIL; + ECL_NIL_SYMBOL->symbol.name = str_NIL; + ECL_NIL_SYMBOL->symbol.gfdef = ECL_NIL; + ECL_NIL_SYMBOL->symbol.plist = ECL_NIL; + ECL_NIL_SYMBOL->symbol.hpack = ECL_NIL; + ECL_NIL_SYMBOL->symbol.stype = ecl_stp_constant; #ifdef ECL_THREADS - ECL_NIL_SYMBOL->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + ECL_NIL_SYMBOL->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - cl_num_symbols_in_core=1; + cl_num_symbols_in_core=1; - ECL_T->symbol.t = (short)t_symbol; - ECL_T->symbol.dynamic = 0; - ECL_T->symbol.value = ECL_T; - ECL_T->symbol.name = str_T; - ECL_T->symbol.gfdef = ECL_NIL; - ECL_T->symbol.plist = ECL_NIL; - ECL_T->symbol.hpack = ECL_NIL; - ECL_T->symbol.stype = ecl_stp_constant; + ECL_T->symbol.t = (short)t_symbol; + ECL_T->symbol.dynamic = 0; + ECL_T->symbol.value = ECL_T; + ECL_T->symbol.name = str_T; + ECL_T->symbol.gfdef = ECL_NIL; + ECL_T->symbol.plist = ECL_NIL; + ECL_T->symbol.hpack = ECL_NIL; + ECL_T->symbol.stype = ecl_stp_constant; #ifdef ECL_THREADS - ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - cl_num_symbols_in_core=2; + cl_num_symbols_in_core=2; #ifdef NO_PATH_MAX - cl_core.path_max = sysconf(_PC_PATH_MAX); + cl_core.path_max = sysconf(_PC_PATH_MAX); #else - cl_core.path_max = MAXPATHLEN; + cl_core.path_max = MAXPATHLEN; #endif env->packages_to_be_created = ECL_NIL; - cl_core.lisp_package = - ecl_make_package(str_common_lisp, - cl_list(2, str_cl, str_LISP), - ECL_NIL); - cl_core.user_package = - ecl_make_package(str_common_lisp_user, - cl_list(2, str_cl_user, str_user), - ecl_list1(cl_core.lisp_package)); - cl_core.keyword_package = - ecl_make_package(str_keyword, ECL_NIL, ECL_NIL); - cl_core.ext_package = - ecl_make_package(str_ext, ECL_NIL, - ecl_list1(cl_core.lisp_package)); - cl_core.system_package = - ecl_make_package(str_si, + cl_core.lisp_package = + ecl_make_package(str_common_lisp, + cl_list(2, str_cl, str_LISP), + ECL_NIL); + cl_core.user_package = + ecl_make_package(str_common_lisp_user, + cl_list(2, str_cl_user, str_user), + ecl_list1(cl_core.lisp_package)); + cl_core.keyword_package = + ecl_make_package(str_keyword, ECL_NIL, ECL_NIL); + cl_core.ext_package = + ecl_make_package(str_ext, ECL_NIL, + ecl_list1(cl_core.lisp_package)); + cl_core.system_package = + ecl_make_package(str_si, cl_list(2,str_system,str_sys), - cl_list(2,cl_core.ext_package, + cl_list(2,cl_core.ext_package, cl_core.lisp_package)); - cl_core.c_package = - ecl_make_package(str_c, + cl_core.c_package = + ecl_make_package(str_c, ecl_list1(str_compiler), - ecl_list1(cl_core.lisp_package)); + ecl_list1(cl_core.lisp_package)); #ifdef CLOS - cl_core.clos_package = - ecl_make_package(str_clos, + cl_core.clos_package = + ecl_make_package(str_clos, ecl_list1(str_mop), ecl_list1(cl_core.lisp_package)); #endif - cl_core.mp_package = - ecl_make_package(str_mp, - ecl_list1(str_multiprocessing), - ecl_list1(cl_core.lisp_package)); + cl_core.mp_package = + ecl_make_package(str_mp, + ecl_list1(str_multiprocessing), + ecl_list1(cl_core.lisp_package)); #ifdef ECL_CLOS_STREAMS - cl_core.gray_package = ecl_make_package(str_gray, ECL_NIL, - CONS(cl_core.lisp_package, ECL_NIL)); + cl_core.gray_package = ecl_make_package(str_gray, ECL_NIL, + CONS(cl_core.lisp_package, ECL_NIL)); #endif - cl_core.ffi_package = - ecl_make_package(str_ffi, + cl_core.ffi_package = + ecl_make_package(str_ffi, ecl_list1(str_uffi), - cl_list(3,cl_core.lisp_package, - cl_core.system_package, - cl_core.ext_package)); + cl_list(3,cl_core.lisp_package, + cl_core.system_package, + cl_core.ext_package)); - ECL_NIL_SYMBOL->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_NIL, cl_core.lisp_package); - cl_export2(ECL_NIL, cl_core.lisp_package); + ECL_NIL_SYMBOL->symbol.hpack = cl_core.lisp_package; + cl_import2(ECL_NIL, cl_core.lisp_package); + cl_export2(ECL_NIL, cl_core.lisp_package); - ECL_T->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_T, cl_core.lisp_package); - cl_export2(ECL_T, cl_core.lisp_package); + ECL_T->symbol.hpack = cl_core.lisp_package; + cl_import2(ECL_T, cl_core.lisp_package); + cl_export2(ECL_T, cl_core.lisp_package); - /* At exit, clean up */ - atexit(cl_shutdown); + /* At exit, clean up */ + atexit(cl_shutdown); - /* These must come _after_ the packages and NIL/T have been created */ - init_all_symbols(); + /* These must come _after_ the packages and NIL/T have been created */ + init_all_symbols(); - /* - * Initialize the per-thread data. - * This cannot come later, because some routines need the - * frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS). - */ + /* + * Initialize the per-thread data. + * This cannot come later, because some routines need the + * frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS). + */ init_big(); - ecl_init_env(env); - ecl_cs_set_org(env); + ecl_init_env(env); + ecl_cs_set_org(env); #if !defined(GBC_BOEHM) - /* We need this because a lot of stuff is to be created */ - init_GC(); + /* We need this because a lot of stuff is to be created */ + init_GC(); #endif - GC_enable(); + GC_enable(); /* * Initialize default pathnames */ #if 1 - ECL_SET(@'*default-pathname-defaults*', si_getcwd(0)); + ECL_SET(@'*default-pathname-defaults*', si_getcwd(0)); #else - ECL_SET(@'*default-pathname-defaults*', - ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, @':local')); + ECL_SET(@'*default-pathname-defaults*', + ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, @':local')); #endif #ifdef ECL_THREADS - env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), + env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); env->thread_local_bindings_size = env->bindings_array->vector.dim; env->thread_local_bindings = env->bindings_array->vector.self.t; - ECL_SET(@'mp::*current-process*', env->own_process); + ECL_SET(@'mp::*current-process*', env->own_process); #endif - /* + /* * Load character names. The following hash table is a map * from names to character codes and viceversa. Note that we * need EQUALP because it has to be case insensitive. - */ - cl_core.char_names = aux = - cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, + */ + cl_core.char_names = aux = + cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ + cl_core.rehash_size, cl_core.rehash_threshold); - for (i = 0; char_names[i].elt.self; i++) { + for (i = 0; char_names[i].elt.self; i++) { cl_object name = (cl_object)(char_names + i); - cl_object code = ecl_make_fixnum(i); - ecl_sethash(name, aux, code); - ecl_sethash(code, aux, name); - } - for (i = 0; i < extra_char_names_size; i++) { + cl_object code = ecl_make_fixnum(i); + ecl_sethash(name, aux, code); + ecl_sethash(code, aux, name); + } + for (i = 0; i < extra_char_names_size; i++) { cl_object name = (cl_object)(extra_char_names + i); - cl_object code = ecl_make_fixnum(extra_char_codes[i]); - ecl_sethash(name, aux, code); - } + cl_object code = ecl_make_fixnum(extra_char_codes[i]); + ecl_sethash(name, aux, code); + } /* * Initialize logical pathname translations. This must come after * the character database has been filled. */ - @si::pathname-translations(2,str_sys, + @si::pathname-translations(2,str_sys, ecl_list1(cl_list(2,str_star_dot_star, str_rel_star_dot_star))); - /* - * Initialize constants (strings, numbers and time). - */ - cl_core.system_properties = - cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, + /* + * Initialize constants (strings, numbers and time). + */ + cl_core.system_properties = + cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ + cl_core.rehash_size, cl_core.rehash_threshold); - cl_core.setf_definitions = - cl__make_hash_table(@'eq', ecl_make_fixnum(256), /* size */ - cl_core.rehash_size, + cl_core.setf_definitions = + cl__make_hash_table(@'eq', ecl_make_fixnum(256), /* size */ + cl_core.rehash_size, cl_core.rehash_threshold); - ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); + ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); - ECL_SET(@'ffi::c-int-max', ecl_make_integer(INT_MAX)); - ECL_SET(@'ffi::c-int-min', ecl_make_integer(INT_MIN)); - ECL_SET(@'ffi::c-long-max', ecl_make_integer(LONG_MAX)); - ECL_SET(@'ffi::c-long-min', ecl_make_integer(LONG_MIN)); - ECL_SET(@'ffi::c-uint-max', ecl_make_unsigned_integer(UINT_MAX)); - ECL_SET(@'ffi::c-ulong-max', ecl_make_unsigned_integer(ULONG_MAX)); + ECL_SET(@'ffi::c-int-max', ecl_make_integer(INT_MAX)); + ECL_SET(@'ffi::c-int-min', ecl_make_integer(INT_MIN)); + ECL_SET(@'ffi::c-long-max', ecl_make_integer(LONG_MAX)); + ECL_SET(@'ffi::c-long-min', ecl_make_integer(LONG_MIN)); + ECL_SET(@'ffi::c-uint-max', ecl_make_unsigned_integer(UINT_MAX)); + ECL_SET(@'ffi::c-ulong-max', ecl_make_unsigned_integer(ULONG_MAX)); #ifdef ecl_long_long_t - ECL_SET(@'ffi::c-long-long-max', ecl_make_long_long(LLONG_MAX)); - ECL_SET(@'ffi::c-ulong-long-max', ecl_make_ulong_long(ULLONG_MAX)); + ECL_SET(@'ffi::c-long-long-max', ecl_make_long_long(LLONG_MAX)); + ECL_SET(@'ffi::c-ulong-long-max', ecl_make_ulong_long(ULLONG_MAX)); #endif - init_unixtime(); + init_unixtime(); - /* - * Initialize I/O subsystem. - */ - init_file(); - init_read(); + /* + * Initialize I/O subsystem. + */ + init_file(); + init_read(); - ECL_SET(@'*print-case*', @':upcase'); + ECL_SET(@'*print-case*', @':upcase'); - /* - * Set up hooks for LOAD, errors and macros. - */ + /* + * Set up hooks for LOAD, errors and macros. + */ #ifdef ECL_THREADS - ECL_SET(@'mp::+load-compile-lock+', - ecl_make_lock(@'mp::+load-compile-lock+', 1)); + ECL_SET(@'mp::+load-compile-lock+', + ecl_make_lock(@'mp::+load-compile-lock+', 1)); #endif - aux = cl_list( + aux = cl_list( #ifdef ENABLE_DLOPEN - 11, + 11, CONS(str_fas, @'si::load-binary'), - CONS(str_fasl, @'si::load-binary'), - CONS(str_fasb, @'si::load-binary'), - CONS(str_FASB, @'si::load-binary'), + CONS(str_fasl, @'si::load-binary'), + CONS(str_fasb, @'si::load-binary'), + CONS(str_FASB, @'si::load-binary'), #else - 7, + 7, #endif - CONS(str_lsp, @'si::load-source'), - CONS(str_lisp, @'si::load-source'), - CONS(str_LSP, @'si::load-source'), - CONS(str_LISP, @'si::load-source'), - CONS(str_fasc, @'si::load-bytecodes'), - CONS(str_FASC, @'si::load-bytecodes'), - CONS(ECL_NIL, @'si::load-source')); - ECL_SET(@'ext::*load-hooks*', aux); - init_error(); - init_macros(); - init_compiler(); + CONS(str_lsp, @'si::load-source'), + CONS(str_lisp, @'si::load-source'), + CONS(str_LSP, @'si::load-source'), + CONS(str_LISP, @'si::load-source'), + CONS(str_fasc, @'si::load-bytecodes'), + CONS(str_FASC, @'si::load-bytecodes'), + CONS(ECL_NIL, @'si::load-source')); + ECL_SET(@'ext::*load-hooks*', aux); + init_error(); + init_macros(); + init_compiler(); - /* - * Set up infrastructure for CLOS. - */ + /* + * Set up infrastructure for CLOS. + */ #ifdef CLOS - ECL_SET(@'si::*class-name-hash-table*', - cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ + ECL_SET(@'si::*class-name-hash-table*', + cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ cl_core.rehash_size, cl_core.rehash_threshold)); #endif - /* - * Features. - */ + /* + * Features. + */ - ECL_SET(@'LAMBDA-LIST-KEYWORDS', - cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', - @'&aux', @'&whole', @'&environment', @'&body')); + ECL_SET(@'LAMBDA-LIST-KEYWORDS', + cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', + @'&aux', @'&whole', @'&environment', @'&body')); for (i = 0, features = ECL_NIL; feature_names[i].elt.self; i++) { int flag; @@ -771,26 +771,26 @@ cl_boot(int argc, char **argv) features = CONS(key, features); } - ECL_SET(@'*features*', features); + ECL_SET(@'*features*', features); - ECL_SET(@'*package*', cl_core.lisp_package); + ECL_SET(@'*package*', cl_core.lisp_package); - /* This has to come before init_LSP/CLOS, because we need - * ecl_clear_compiler_properties() to work in init_CLOS(). */ - ecl_set_option(ECL_OPT_BOOTED, 1); + /* This has to come before init_LSP/CLOS, because we need + * ecl_clear_compiler_properties() to work in init_CLOS(). */ + ecl_set_option(ECL_OPT_BOOTED, 1); - ecl_init_module(OBJNULL,init_lib_LSP); + ecl_init_module(OBJNULL,init_lib_LSP); - if (cl_fboundp(@'ext::make-encoding') != ECL_NIL) { - maybe_fix_console_stream(cl_core.standard_input); - maybe_fix_console_stream(cl_core.standard_output); - maybe_fix_console_stream(cl_core.error_output); - } + if (cl_fboundp(@'ext::make-encoding') != ECL_NIL) { + maybe_fix_console_stream(cl_core.standard_input); + maybe_fix_console_stream(cl_core.standard_output); + maybe_fix_console_stream(cl_core.error_output); + } - /* Jump to top level */ - ECL_SET(@'*package*', cl_core.user_package); - init_unixint(1); - return 1; + /* Jump to top level */ + ECL_SET(@'*package*', cl_core.user_package); + init_unixint(1); + return 1; } /************************* ENVIRONMENT ROUTINES ***********************/ @@ -812,11 +812,11 @@ cl_boot(int argc, char **argv) if (process != this) mp_process_join(process); } - /* FIXME! We need to do this because of a problem in GC - * When the thread exits, sometimes the dyld library gets - * called, and if we call dlopen() at the same time we - * cause ECL to hang */ - ecl_musleep(1e-3, 1); + /* FIXME! We need to do this because of a problem in GC + * When the thread exits, sometimes the dyld library gets + * called, and if we call dlopen() at the same time we + * cause ECL to hang */ + ecl_musleep(1e-3, 1); } #endif ECL_SET(@'ext::*program-exit-code*', code); @@ -835,70 +835,70 @@ cl_boot(int argc, char **argv) cl_object si_argc() { - @(return ecl_make_fixnum(ARGC)) + @(return ecl_make_fixnum(ARGC)) } cl_object si_argv(cl_object index) { - if (ECL_FIXNUMP(index)) { - cl_fixnum i = ecl_fixnum(index); - if (i >= 0 && i < ARGC) - @(return make_base_string_copy(ARGV[i])); - } - FEerror("Illegal argument index: ~S.", 1, index); + if (ECL_FIXNUMP(index)) { + cl_fixnum i = ecl_fixnum(index); + if (i >= 0 && i < ARGC) + @(return make_base_string_copy(ARGV[i])); + } + FEerror("Illegal argument index: ~S.", 1, index); } cl_object si_getenv(cl_object var) { - const char *value; + const char *value; /* Strings have to be null terminated base strings */ - var = si_copy_to_simple_base_string(var); - value = getenv((char*)var->base_string.self); - @(return ((value == NULL)? ECL_NIL : make_base_string_copy(value))) + var = si_copy_to_simple_base_string(var); + value = getenv((char*)var->base_string.self); + @(return ((value == NULL)? ECL_NIL : make_base_string_copy(value))) } #if defined(HAVE_SETENV) || defined(HAVE_PUTENV) cl_object si_setenv(cl_object var, cl_object value) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum ret_val; + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum ret_val; - /* Strings have to be null terminated base strings */ - var = si_copy_to_simple_base_string(var); - if (value == ECL_NIL) { + /* Strings have to be null terminated base strings */ + var = si_copy_to_simple_base_string(var); + if (value == ECL_NIL) { #ifdef HAVE_SETENV - /* Remove the variable when setting to nil, so that - * (si:setenv "foo" nil), then (si:getenv "foo) returns - * the right thing. */ - unsetenv((char*)var->base_string.self); + /* Remove the variable when setting to nil, so that + * (si:setenv "foo" nil), then (si:getenv "foo) returns + * the right thing. */ + unsetenv((char*)var->base_string.self); #else #if defined(ECL_MS_WINDOWS_HOST) - si_setenv(var, cl_core.null_string); + si_setenv(var, cl_core.null_string); #else - putenv((char*)var->base_string.self); + putenv((char*)var->base_string.self); #endif #endif - ret_val = 0; - } else { + ret_val = 0; + } else { #ifdef HAVE_SETENV - value = si_copy_to_simple_base_string(value); - ret_val = setenv((char*)var->base_string.self, - (char*)value->base_string.self, 1); + value = si_copy_to_simple_base_string(value); + ret_val = setenv((char*)var->base_string.self, + (char*)value->base_string.self, 1); #else - value = cl_format(4, ECL_NIL, make_constant_base_string("~A=~A"), var, - value); - value = si_copy_to_simple_base_string(value); - putenv((char*)value->base_string.self); + value = cl_format(4, ECL_NIL, make_constant_base_string("~A=~A"), var, + value); + value = si_copy_to_simple_base_string(value); + putenv((char*)value->base_string.self); #endif - } - if (ret_val == -1) - CEerror(ECL_T, "SI:SETENV failed: insufficient space in environment.", - 1, ECL_NIL); - ecl_return1(the_env, value); + } + if (ret_val == -1) + CEerror(ECL_T, "SI:SETENV failed: insufficient space in environment.", + 1, ECL_NIL); + ecl_return1(the_env, value); } #endif @@ -929,26 +929,26 @@ si_environ(void) cl_object si_pointer(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return1(the_env, ecl_make_unsigned_integer((cl_index)x)); + const cl_env_ptr the_env = ecl_process_env(); + ecl_return1(the_env, ecl_make_unsigned_integer((cl_index)x)); } #if defined(ECL_MS_WINDOWS_HOST) void ecl_get_commandline_args(int* argc, char*** argv) { - LPWSTR *wArgs; - int i; + LPWSTR *wArgs; + int i; - if (argc == NULL || argv == NULL) - return; + if (argc == NULL || argv == NULL) + return; - wArgs = CommandLineToArgvW(GetCommandLineW(), argc); - *argv = (char**)malloc(sizeof(char*)*(*argc)); - for (i=0; i<*argc; i++) { - int len = wcslen(wArgs[i]); - (*argv)[i] = (char*)malloc(2*(len+1)); - wcstombs((*argv)[i], wArgs[i], len+1); - } - LocalFree(wArgs); + wArgs = CommandLineToArgvW(GetCommandLineW(), argc); + *argv = (char**)malloc(sizeof(char*)*(*argc)); + for (i=0; i<*argc; i++) { + int len = wcslen(wArgs[i]); + (*argv)[i] = (char*)malloc(2*(len+1)); + wcstombs((*argv)[i], wArgs[i], len+1); + } + LocalFree(wArgs); } #endif diff --git a/src/c/mapfun.d b/src/c/mapfun.d index 563d3e0fd..ba657745f 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -20,156 +20,156 @@ #include #define PREPARE_MAP(env, list, cdrs_frame, cars_frame, narg) \ - struct ecl_stack_frame frames_aux[2]; \ - const cl_object cdrs_frame = (cl_object)frames_aux; \ + struct ecl_stack_frame frames_aux[2]; \ + const cl_object cdrs_frame = (cl_object)frames_aux; \ const cl_object cars_frame = (cl_object)(frames_aux+1); \ - ECL_STACK_FRAME_FROM_VA_LIST(env,cdrs_frame,list); \ - ECL_STACK_FRAME_COPY(cars_frame, cdrs_frame); \ - narg = cars_frame->frame.size; \ - if (ecl_unlikely(narg == 0)) { \ - FEprogram_error_noreturn("MAP*: Too few arguments", 0); \ - } + ECL_STACK_FRAME_FROM_VA_LIST(env,cdrs_frame,list); \ + ECL_STACK_FRAME_COPY(cars_frame, cdrs_frame); \ + narg = cars_frame->frame.size; \ + if (ecl_unlikely(narg == 0)) { \ + FEprogram_error_noreturn("MAP*: Too few arguments", 0); \ + } @(defun mapcar (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[mapcar], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); - val = &ECL_CONS_CDR(*val); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); + val = &ECL_CONS_CDR(*val); + } } @) @(defun maplist (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[maplist], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); - val = &ECL_CONS_CDR(*val); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun)); + val = &ECL_CONS_CDR(*val); + } } @) @(defun mapc (fun &rest lists) - cl_object onelist; + cl_object onelist; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[mapc], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return onelist) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - ecl_apply_from_stack_frame(cars_frame, fun); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return onelist) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + ecl_apply_from_stack_frame(cars_frame, fun); + } } @) @(defun mapl (fun &rest lists) - cl_object onelist; + cl_object onelist; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0); + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[mapl], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return onelist) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - ecl_apply_from_stack_frame(cars_frame, fun); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return onelist) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + ecl_apply_from_stack_frame(cars_frame, fun); + } } @) @(defun mapcan (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[mapcan], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_apply_from_stack_frame(cars_frame, fun); - while (CONSP(*val)) - val = &ECL_CONS_CDR(*val); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, ECL_CONS_CAR(cdr)); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_apply_from_stack_frame(cars_frame, fun); + while (CONSP(*val)) + val = &ECL_CONS_CDR(*val); + } } @) @(defun mapcon (fun &rest lists) - cl_object res, *val = &res; + cl_object res, *val = &res; @ { - PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); - res = ECL_NIL; - while (TRUE) { - cl_index i; - for (i = 0; i < narg; i++) { - cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); + PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg); + res = ECL_NIL; + while (TRUE) { + cl_index i; + for (i = 0; i < narg; i++) { + cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i); if (ecl_unlikely(!LISTP(cdr))) FEwrong_type_nth_arg(@[mapcon], i+2, cdr, @[list]); - if (Null(cdr)) { - ecl_stack_frame_close(cars_frame); - ecl_stack_frame_close(cdrs_frame); - @(return res) - } - ECL_STACK_FRAME_SET(cars_frame, i, cdr); - ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); - } - *val = ecl_apply_from_stack_frame(cars_frame, fun); - while (CONSP(*val)) - val = &ECL_CONS_CDR(*val); - } + if (Null(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); + @(return res) + } + ECL_STACK_FRAME_SET(cars_frame, i, cdr); + ECL_STACK_FRAME_SET(cdrs_frame, i, ECL_CONS_CDR(cdr)); + } + *val = ecl_apply_from_stack_frame(cars_frame, fun); + while (CONSP(*val)) + val = &ECL_CONS_CDR(*val); + } } @) diff --git a/src/c/multival.d b/src/c/multival.d index 2a13edcdc..a41ef48cf 100644 --- a/src/c/multival.d +++ b/src/c/multival.d @@ -19,35 +19,35 @@ #include @(defun values (&rest args) - cl_object output; + cl_object output; @ - unlikely_if (narg > ECL_MULTIPLE_VALUES_LIMIT) - FEerror("Too many values in VALUES",0); - the_env->nvalues = narg; - output = ECL_NIL; - if (narg) { - int i = 0; - do { - the_env->values[i] = ecl_va_arg(args); - } while (++i < narg); - output = the_env->values[0]; - } - return output; + unlikely_if (narg > ECL_MULTIPLE_VALUES_LIMIT) + FEerror("Too many values in VALUES",0); + the_env->nvalues = narg; + output = ECL_NIL; + if (narg) { + int i = 0; + do { + the_env->values[i] = ecl_va_arg(args); + } while (++i < narg); + output = the_env->values[0]; + } + return output; @) cl_object cl_values_list(cl_object list) { - cl_env_ptr the_env = ecl_process_env(); - int i; - the_env->values[0] = ECL_NIL; - for (i = 0; !Null(list); list=ECL_CONS_CDR(list)) { + cl_env_ptr the_env = ecl_process_env(); + int i; + the_env->values[0] = ECL_NIL; + for (i = 0; !Null(list); list=ECL_CONS_CDR(list)) { unlikely_if (!LISTP(list)) - FEtype_error_list(list); - unlikely_if (i == ECL_MULTIPLE_VALUES_LIMIT) - FEerror("Too many values in VALUES-LIST",0); - the_env->values[i++] = ECL_CONS_CAR(list); - } - the_env->nvalues = i; - return the_env->values[0]; + FEtype_error_list(list); + unlikely_if (i == ECL_MULTIPLE_VALUES_LIMIT) + FEerror("Too many values in VALUES-LIST",0); + the_env->values[i++] = ECL_CONS_CAR(list); + } + the_env->nvalues = i; + return the_env->values[0]; } diff --git a/src/c/newhash.h b/src/c/newhash.h index 891e26005..461cfe415 100644 --- a/src/c/newhash.h +++ b/src/c/newhash.h @@ -12,72 +12,72 @@ * 64 bit version */ #define GOLDEN_RATIO 0x9e3779b97f4a7c13L -#define mix(a,b,c) \ - { \ - a=a-b; a=a-c; a=a^(c>>43); \ - b=b-c; b=b-a; b=b^(a<<9); \ - c=c-a; c=c-b; c=c^(b>>8); \ - a=a-b; a=a-c; a=a^(c>>38); \ - b=b-c; b=b-a; b=b^(a<<23); \ - c=c-a; c=c-b; c=c^(b>>5); \ - a=a-b; a=a-c; a=a^(c>>35); \ - b=b-c; b=b-a; b=b^(a<<49); \ - c=c-a; c=c-b; c=c^(b>>11); \ - a=a-b; a=a-c; a=a^(c>>12); \ - b=b-c; b=b-a; b=b^(a<<18); \ - c=c-a; c=c-b; c=c^(b>>22); \ - } +#define mix(a,b,c) \ + { \ + a=a-b; a=a-c; a=a^(c>>43); \ + b=b-c; b=b-a; b=b^(a<<9); \ + c=c-a; c=c-b; c=c^(b>>8); \ + a=a-b; a=a-c; a=a^(c>>38); \ + b=b-c; b=b-a; b=b^(a<<23); \ + c=c-a; c=c-b; c=c^(b>>5); \ + a=a-b; a=a-c; a=a^(c>>35); \ + b=b-c; b=b-a; b=b^(a<<49); \ + c=c-a; c=c-b; c=c^(b>>11); \ + a=a-b; a=a-c; a=a^(c>>12); \ + b=b-c; b=b-a; b=b^(a<<18); \ + c=c-a; c=c-b; c=c^(b>>22); \ + } -#define extract_word(k) \ - (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)+ \ - ((cl_index)k[4]<<32)+((cl_index)k[5]<<40)+((cl_index)k[6]<<48)+ \ - ((cl_index)k[7]<<52)) +#define extract_word(k) \ + (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)+ \ + ((cl_index)k[4]<<32)+((cl_index)k[5]<<40)+((cl_index)k[6]<<48)+ \ + ((cl_index)k[7]<<52)) static cl_index hash_string(cl_index initval, const unsigned char *k, cl_index length) { - register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; - register cl_index len; - for (len = length; len >= 24; len -= 24) { - a += extract_word(k); k+=8; - b += extract_word(k); k+=8; - c += extract_word(k); k+=8; - mix(a,b,c); - } + register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; + register cl_index len; + for (len = length; len >= 24; len -= 24) { + a += extract_word(k); k+=8; + b += extract_word(k); k+=8; + c += extract_word(k); k+=8; + mix(a,b,c); + } - /*------------------------------------- handle the last 11 bytes */ - c += length; - switch(len) { - /* all the case statements fall through */ - case 23: c+=((cl_index)k[22]<<52); - case 22: c+=((cl_index)k[21]<<48); - case 21: c+=((cl_index)k[20]<<40); - case 20: c+=((cl_index)k[19]<<32); - case 19: c+=((cl_index)k[18]<<24); - case 18: c+=((cl_index)k[17]<<16); - case 17: c+=((cl_index)k[16]<<8); - /* the first byte of c is reserved for the length */ - case 16: b+=((cl_index)k[15]<<52); - case 15: b+=((cl_index)k[14]<<48); - case 14: b+=((cl_index)k[13]<<40); - case 13: b+=((cl_index)k[12]<<32); - case 12: b+=((cl_index)k[11]<<24); - case 11: b+=((cl_index)k[10]<<16); - case 10: b+=((cl_index)k[9]<<8); - case 9 : b+=k[8]; - case 8 : a+=((cl_index)k[7]<<52); - case 7 : a+=((cl_index)k[6]<<48); - case 6 : a+=((cl_index)k[5]<<40); - case 5 : a+=((cl_index)k[4]<<32); - case 4 : a+=((cl_index)k[3]<<24); - case 3 : a+=((cl_index)k[2]<<16); - case 2 : a+=((cl_index)k[1]<<8); - case 1 : a+=k[0]; - /* case 0: nothing left to add */ - } - mix(a,b,c); - /*-------------------------------------------- report the result */ - return c; + /*------------------------------------- handle the last 11 bytes */ + c += length; + switch(len) { + /* all the case statements fall through */ + case 23: c+=((cl_index)k[22]<<52); + case 22: c+=((cl_index)k[21]<<48); + case 21: c+=((cl_index)k[20]<<40); + case 20: c+=((cl_index)k[19]<<32); + case 19: c+=((cl_index)k[18]<<24); + case 18: c+=((cl_index)k[17]<<16); + case 17: c+=((cl_index)k[16]<<8); + /* the first byte of c is reserved for the length */ + case 16: b+=((cl_index)k[15]<<52); + case 15: b+=((cl_index)k[14]<<48); + case 14: b+=((cl_index)k[13]<<40); + case 13: b+=((cl_index)k[12]<<32); + case 12: b+=((cl_index)k[11]<<24); + case 11: b+=((cl_index)k[10]<<16); + case 10: b+=((cl_index)k[9]<<8); + case 9 : b+=k[8]; + case 8 : a+=((cl_index)k[7]<<52); + case 7 : a+=((cl_index)k[6]<<48); + case 6 : a+=((cl_index)k[5]<<40); + case 5 : a+=((cl_index)k[4]<<32); + case 4 : a+=((cl_index)k[3]<<24); + case 3 : a+=((cl_index)k[2]<<16); + case 2 : a+=((cl_index)k[1]<<8); + case 1 : a+=k[0]; + /* case 0: nothing left to add */ + } + mix(a,b,c); + /*-------------------------------------------- report the result */ + return c; } #else @@ -86,98 +86,98 @@ hash_string(cl_index initval, const unsigned char *k, cl_index length) */ #define GOLDEN_RATIO 0x9e3779b9L -#define mix(a,b,c) \ - { \ - a -= b; a -= c; a ^= (c>>13); \ - b -= c; b -= a; b ^= (a<<8); \ - c -= a; c -= b; c ^= (b>>13); \ - a -= b; a -= c; a ^= (c>>12); \ - b -= c; b -= a; b ^= (a<<16); \ - c -= a; c -= b; c ^= (b>>5); \ - a -= b; a -= c; a ^= (c>>3); \ - b -= c; b -= a; b ^= (a<<10); \ - c -= a; c -= b; c ^= (b>>15); \ - } -#define extract_word(k) \ - (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)) +#define mix(a,b,c) \ + { \ + a -= b; a -= c; a ^= (c>>13); \ + b -= c; b -= a; b ^= (a<<8); \ + c -= a; c -= b; c ^= (b>>13); \ + a -= b; a -= c; a ^= (c>>12); \ + b -= c; b -= a; b ^= (a<<16); \ + c -= a; c -= b; c ^= (b>>5); \ + a -= b; a -= c; a ^= (c>>3); \ + b -= c; b -= a; b ^= (a<<10); \ + c -= a; c -= b; c ^= (b>>15); \ + } +#define extract_word(k) \ + (k[0]+((cl_index)k[1]<<8)+((cl_index)k[2]<<16)+((cl_index)k[3]<<24)) static cl_index hash_string(cl_index initval, const unsigned char *k, cl_index length) { - register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; - register cl_index len; - for (len = length; len >= 12; len -= 12) { - a += extract_word(k); k += 4; - b += extract_word(k); k += 4; - c += extract_word(k); k += 4; - mix(a,b,c); - } + register cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, c = initval; + register cl_index len; + for (len = length; len >= 12; len -= 12) { + a += extract_word(k); k += 4; + b += extract_word(k); k += 4; + c += extract_word(k); k += 4; + mix(a,b,c); + } - /*------------------------------------- handle the last 11 bytes */ - c += length; - switch(len) { - /* all the case statements fall through */ - case 11: c+=((cl_index)k[10]<<24); - case 10: c+=((cl_index)k[9]<<16); - case 9 : c+=((cl_index)k[8]<<8); - /* the first byte of c is reserved for the length */ - case 8 : b+=((cl_index)k[7]<<24); - case 7 : b+=((cl_index)k[6]<<16); - case 6 : b+=((cl_index)k[5]<<8); - case 5 : b+=k[4]; - case 4 : a+=((cl_index)k[3]<<24); - case 3 : a+=((cl_index)k[2]<<16); - case 2 : a+=((cl_index)k[1]<<8); - case 1 : a+=k[0]; - /* case 0: nothing left to add */ - } - mix(a,b,c); - /*-------------------------------------------- report the result */ - return c; + /*------------------------------------- handle the last 11 bytes */ + c += length; + switch(len) { + /* all the case statements fall through */ + case 11: c+=((cl_index)k[10]<<24); + case 10: c+=((cl_index)k[9]<<16); + case 9 : c+=((cl_index)k[8]<<8); + /* the first byte of c is reserved for the length */ + case 8 : b+=((cl_index)k[7]<<24); + case 7 : b+=((cl_index)k[6]<<16); + case 6 : b+=((cl_index)k[5]<<8); + case 5 : b+=k[4]; + case 4 : a+=((cl_index)k[3]<<24); + case 3 : a+=((cl_index)k[2]<<16); + case 2 : a+=((cl_index)k[1]<<8); + case 1 : a+=k[0]; + /* case 0: nothing left to add */ + } + mix(a,b,c); + /*-------------------------------------------- report the result */ + return c; } #endif static cl_index hash_word(cl_index c, cl_index w) { - cl_index a = w + GOLDEN_RATIO, b = GOLDEN_RATIO; - mix(a, b, c); - return c; + cl_index a = w + GOLDEN_RATIO, b = GOLDEN_RATIO; + mix(a, b, c); + return c; } static cl_index hash_base_string(const ecl_base_char *s, cl_index len, cl_index h) { - cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; - for (i = len; i >= 3; i -= 3) { - a += *s; s++; - b += *s; s++; - h += *s; s++; - mix(a, b, h); - } - switch (i) { - case 2: a += *s; s++; - case 1: b += *s; - default: h += len; - } - mix(a, b, h); - return h; + cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; + for (i = len; i >= 3; i -= 3) { + a += *s; s++; + b += *s; s++; + h += *s; s++; + mix(a, b, h); + } + switch (i) { + case 2: a += *s; s++; + case 1: b += *s; + default: h += len; + } + mix(a, b, h); + return h; } #ifdef ECL_UNICODE static cl_index hash_full_string(const ecl_character *s, cl_index len, cl_index h) { - cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; - for (i = len; i >= 3; i -= 3) { - a += (*s); s++; - b += (*s); s++; - h += (*s); s++; - mix(a, b, h); - } - switch (i) { - case 2: a += (*s); s++; - case 1: b += (*s); - default: h += len; - } - mix(a, b, h); - return h; + cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; + for (i = len; i >= 3; i -= 3) { + a += (*s); s++; + b += (*s); s++; + h += (*s); s++; + mix(a, b, h); + } + switch (i) { + case 2: a += (*s); s++; + case 1: b += (*s); + default: h += len; + } + mix(a, b, h); + return h; } #endif diff --git a/src/c/num_arith.d b/src/c/num_arith.d index d198dc129..53d2cb85b 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -21,47 +21,47 @@ cl_object ecl_integer_divide(cl_object x, cl_object y) { - cl_type tx, ty; + cl_type tx, ty; - tx = ecl_t_of(x); - ty = ecl_t_of(y); - if (tx == t_fixnum) { - if (ty == t_fixnum) { - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y)); - } else if (ty == t_bignum) { + tx = ecl_t_of(x); + ty = ecl_t_of(y); + if (tx == t_fixnum) { + if (ty == t_fixnum) { + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + return ecl_make_fixnum(ecl_fixnum(x) / ecl_fixnum(y)); + } else if (ty == t_bignum) { return _ecl_fix_divided_by_big(ecl_fixnum(x), y); - } else { + } else { FEwrong_type_nth_arg(@[round], 2, y, @[integer]); } - } - if (tx == t_bignum) { - if (ty == t_bignum) { - return _ecl_big_divided_by_big(x, y); - } else if (ty == t_fixnum) { + } + if (tx == t_bignum) { + if (ty == t_bignum) { + return _ecl_big_divided_by_big(x, y); + } else if (ty == t_fixnum) { return _ecl_big_divided_by_fix(x, ecl_fixnum(y)); - } else { + } else { FEwrong_type_nth_arg(@[round], 2, y, @[integer]); - } - } + } + } FEwrong_type_nth_arg(@[round], 1, x, @[integer]); } @(defun gcd (&rest nums) - cl_object gcd; + cl_object gcd; @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: ecl_gcd() checks types */ - gcd = ecl_va_arg(nums); - if (narg == 1) { - assert_type_integer(gcd); - @(return (ecl_minusp(gcd) ? ecl_negate(gcd) : gcd)) - } - while (--narg) - gcd = ecl_gcd(gcd, ecl_va_arg(nums)); - @(return gcd) + if (narg == 0) + @(return ecl_make_fixnum(0)) + /* INV: ecl_gcd() checks types */ + gcd = ecl_va_arg(nums); + if (narg == 1) { + assert_type_integer(gcd); + @(return (ecl_minusp(gcd) ? ecl_negate(gcd) : gcd)) + } + while (--narg) + gcd = ecl_gcd(gcd, ecl_va_arg(nums)); + @(return gcd) @) cl_object @@ -70,42 +70,42 @@ ecl_gcd(cl_object x, cl_object y) ECL_WITH_TEMP_BIGNUM(x_big,1); ECL_WITH_TEMP_BIGNUM(y_big,1); - switch (ecl_t_of(x)) { - case t_fixnum: + switch (ecl_t_of(x)) { + case t_fixnum: _ecl_big_set_fixnum(x_big, ecl_fixnum(x)); x = x_big; - case t_bignum: - break; - default: - FEwrong_type_nth_arg(@[gcd], 1, x, @[integer]); - } - switch (ecl_t_of(y)) { - case t_fixnum: + case t_bignum: + break; + default: + FEwrong_type_nth_arg(@[gcd], 1, x, @[integer]); + } + switch (ecl_t_of(y)) { + case t_fixnum: _ecl_big_set_fixnum(y_big, ecl_fixnum(y)); y = y_big; - case t_bignum: + case t_bignum: break; - default: - FEwrong_type_nth_arg(@[gcd], 2, y, @[integer]); + default: + FEwrong_type_nth_arg(@[gcd], 2, y, @[integer]); } return _ecl_big_gcd(x, y); } @(defun lcm (&rest nums) - cl_object lcm; + cl_object lcm; @ - if (narg == 0) - @(return ecl_make_fixnum(1)) - /* INV: ecl_gcd() checks types. By placing `numi' before `lcm' in - this call, we make sure that errors point to `numi' */ - lcm = ecl_va_arg(nums); - assert_type_integer(lcm); - while (narg-- > 1) { - cl_object numi = ecl_va_arg(nums); - cl_object t = ecl_times(lcm, numi); - cl_object g = ecl_gcd(numi, lcm); - if (g != ecl_make_fixnum(0)) - lcm = ecl_divide(t, g); - } - @(return (ecl_minusp(lcm) ? ecl_negate(lcm) : lcm)) + if (narg == 0) + @(return ecl_make_fixnum(1)) + /* INV: ecl_gcd() checks types. By placing `numi' before `lcm' in + this call, we make sure that errors point to `numi' */ + lcm = ecl_va_arg(nums); + assert_type_integer(lcm); + while (narg-- > 1) { + cl_object numi = ecl_va_arg(nums); + cl_object t = ecl_times(lcm, numi); + cl_object g = ecl_gcd(numi, lcm); + if (g != ecl_make_fixnum(0)) + lcm = ecl_divide(t, g); + } + @(return (ecl_minusp(lcm) ? ecl_negate(lcm) : lcm)) @) diff --git a/src/c/num_co.d b/src/c/num_co.d index b210380ce..5ce9a2ce3 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -16,10 +16,10 @@ */ /* - IMPLEMENTATION-DEPENDENT + IMPLEMENTATION-DEPENDENT - This file contains those functions - that know the representation of floating-point numbers. + This file contains those functions + that know the representation of floating-point numbers. */ #define ECL_INCLUDE_MATH_H @@ -46,439 +46,439 @@ otherwise coerce to same float type as second arg */ @(defun float (x &optional (y OBJNULL)) - cl_type ty, tx; + cl_type ty, tx; @ - if (y != OBJNULL) { - ty = ecl_t_of(y); - } else { - ty = t_singlefloat; - } - switch (tx = ecl_t_of(x)) { - case t_singlefloat: - case t_doublefloat: + if (y != OBJNULL) { + ty = ecl_t_of(y); + } else { + ty = t_singlefloat; + } + switch (tx = ecl_t_of(x)) { + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - if (y == OBJNULL || ty == tx) - break; - case t_fixnum: - case t_bignum: - case t_ratio: - switch (ty) { - case t_singlefloat: - x = ecl_make_single_float(ecl_to_double(x)); break; - case t_doublefloat: - x = ecl_make_double_float(ecl_to_double(x)); break; + if (y == OBJNULL || ty == tx) + break; + case t_fixnum: + case t_bignum: + case t_ratio: + switch (ty) { + case t_singlefloat: + x = ecl_make_single_float(ecl_to_double(x)); break; + case t_doublefloat: + x = ecl_make_double_float(ecl_to_double(x)); break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_long_float(ecl_to_long_double(x)); break; + case t_longfloat: + x = ecl_make_long_float(ecl_to_long_double(x)); break; #endif - default: + default: FEwrong_type_nth_arg(@[float],2,y,@[float]); - } - break; - default: + } + break; + default: FEwrong_type_nth_arg(@[float],1,x,@[real]); - } - @(return x) + } + @(return x) @) cl_object cl_numerator(cl_object x) { - switch (ecl_t_of(x)) { - case t_ratio: - x = x->ratio.num; - break; - case t_fixnum: - case t_bignum: - break; - default: + switch (ecl_t_of(x)) { + case t_ratio: + x = x->ratio.num; + break; + case t_fixnum: + case t_bignum: + break; + default: FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); - } - @(return x) + } + @(return x) } cl_object cl_denominator(cl_object x) { - switch (ecl_t_of(x)) { - case t_ratio: - x = x->ratio.den; - break; - case t_fixnum: - case t_bignum: - x = ecl_make_fixnum(1); - break; - default: + switch (ecl_t_of(x)) { + case t_ratio: + x = x->ratio.den; + break; + case t_fixnum: + case t_bignum: + x = ecl_make_fixnum(1); + break; + default: FEwrong_type_nth_arg(@[numerator],1,x,@[rational]); - } - @(return x) + } + @(return x) } cl_object cl_mod(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: #'floor always outputs two values */ - @floor(2, x, y); - ecl_return1(the_env, the_env->values[1]); + const cl_env_ptr the_env = ecl_process_env(); + /* INV: #'floor always outputs two values */ + @floor(2, x, y); + ecl_return1(the_env, the_env->values[1]); } cl_object cl_rem(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - @truncate(2, x, y); - ecl_return1(the_env, the_env->values[1]); + const cl_env_ptr the_env = ecl_process_env(); + @truncate(2, x, y); + ecl_return1(the_env, the_env->values[1]); } cl_object cl_decode_float(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int e, s; - cl_type tx = ecl_t_of(x); - float f; + const cl_env_ptr the_env = ecl_process_env(); + int e, s; + cl_type tx = ecl_t_of(x); + float f; - switch (tx) { - case t_singlefloat: { - f = ecl_single_float(x); - if (f >= 0.0) { - s = 1; - } else { - f = -f; - s = 0; - } - f = frexpf(f, &e); - x = ecl_make_single_float(f); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - if (d >= 0.0) { - s = 1; - } else { - d = -d; - s = 0; - } - d = frexp(d, &e); - x = ecl_make_double_float(d); - break; - } + switch (tx) { + case t_singlefloat: { + f = ecl_single_float(x); + if (f >= 0.0) { + s = 1; + } else { + f = -f; + s = 0; + } + f = frexpf(f, &e); + x = ecl_make_single_float(f); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + if (d >= 0.0) { + s = 1; + } else { + d = -d; + s = 0; + } + d = frexp(d, &e); + x = ecl_make_double_float(d); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - if (d >= 0.0) - s = 1; - else { - d = -d; - s = 0; - } - d = frexpl(d, &e); - x = ecl_make_long_float(d); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + if (d >= 0.0) + s = 1; + else { + d = -d; + s = 0; + } + d = frexpl(d, &e); + x = ecl_make_long_float(d); + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[decode-float],1,x,@[float]); - } - ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s)); + } + ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s)); } cl_object cl_scale_float(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum k; + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum k; - if (ECL_FIXNUMP(y)) { - k = ecl_fixnum(y); - } else { - FEwrong_type_nth_arg(@[scale-float],2,y,@[fixnum]); - } - switch (ecl_t_of(x)) { - case t_singlefloat: - x = ecl_make_single_float(ldexpf(ecl_single_float(x), k)); - break; - case t_doublefloat: - x = ecl_make_double_float(ldexp(ecl_double_float(x), k)); - break; + if (ECL_FIXNUMP(y)) { + k = ecl_fixnum(y); + } else { + FEwrong_type_nth_arg(@[scale-float],2,y,@[fixnum]); + } + switch (ecl_t_of(x)) { + case t_singlefloat: + x = ecl_make_single_float(ldexpf(ecl_single_float(x), k)); + break; + case t_doublefloat: + x = ecl_make_double_float(ldexp(ecl_double_float(x), k)); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_long_float(ldexpl(ecl_long_float(x), k)); - break; + case t_longfloat: + x = ecl_make_long_float(ldexpl(ecl_long_float(x), k)); + break; #endif - default: + default: FEwrong_type_nth_arg(@[scale-float],1,x,@[float]); - } - ecl_return1(the_env, x); + } + ecl_return1(the_env, x); } cl_object cl_float_radix(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - if (ecl_unlikely(cl_floatp(x) != ECL_T)) { - FEwrong_type_nth_arg(@[float-radix],1,x,@[float]); - } - ecl_return1(the_env, ecl_make_fixnum(FLT_RADIX)); + const cl_env_ptr the_env = ecl_process_env(); + if (ecl_unlikely(cl_floatp(x) != ECL_T)) { + FEwrong_type_nth_arg(@[float-radix],1,x,@[float]); + } + ecl_return1(the_env, ecl_make_fixnum(FLT_RADIX)); } int ecl_signbit(cl_object x) { - switch (ecl_t_of(x)) { - case t_singlefloat: - return signbit(ecl_single_float(x)); - case t_doublefloat: - return signbit(ecl_double_float(x)); + switch (ecl_t_of(x)) { + case t_singlefloat: + return signbit(ecl_single_float(x)); + case t_doublefloat: + return signbit(ecl_double_float(x)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return signbit(ecl_long_float(x)); + case t_longfloat: + return signbit(ecl_long_float(x)); #endif - default: + default: FEwrong_type_nth_arg(@[float-sign],1,x,@[float]); - } + } } @(defun float_sign (x &optional (y x yp)) - int negativep; + int negativep; @ - if (!yp) { - y = cl_float(2, ecl_make_fixnum(1), x); - } - negativep = ecl_signbit(x); - switch (ecl_t_of(y)) { - case t_singlefloat: { - float f = ecl_single_float(y); + if (!yp) { + y = cl_float(2, ecl_make_fixnum(1), x); + } + negativep = ecl_signbit(x); + switch (ecl_t_of(y)) { + case t_singlefloat: { + float f = ecl_single_float(y); if (signbit(f) != negativep) y = ecl_make_single_float(-f); - break; - } - case t_doublefloat: { - double f = ecl_double_float(y); + break; + } + case t_doublefloat: { + double f = ecl_double_float(y); if (signbit(f) != negativep) y = ecl_make_double_float(-f); - break; - } + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double f = ecl_long_float(y); + case t_longfloat: { + long double f = ecl_long_float(y); if (signbit(f) != negativep) y = ecl_make_long_float(-f); - break; - } + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[float-sign],2,y,@[float]); - } - @(return y); + } + @(return y); @) cl_object cl_float_digits(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - switch (ecl_t_of(x)) { - case t_singlefloat: - x = ecl_make_fixnum(FLT_MANT_DIG); - break; - case t_doublefloat: - x = ecl_make_fixnum(DBL_MANT_DIG); - break; + const cl_env_ptr the_env = ecl_process_env(); + switch (ecl_t_of(x)) { + case t_singlefloat: + x = ecl_make_fixnum(FLT_MANT_DIG); + break; + case t_doublefloat: + x = ecl_make_fixnum(DBL_MANT_DIG); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - x = ecl_make_fixnum(LDBL_MANT_DIG); - break; + case t_longfloat: + x = ecl_make_fixnum(LDBL_MANT_DIG); + break; #endif - default: + default: FEwrong_type_nth_arg(@[float-digits],1,x,@[float]); - } - ecl_return1(the_env, x); + } + ecl_return1(the_env, x); } cl_object cl_float_precision(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int precision; - switch (ecl_t_of(x)) { - case t_singlefloat: { - float f = ecl_single_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexpf(f, &exp); - if (exp >= FLT_MIN_EXP) { - precision = FLT_MANT_DIG; - } else { - precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp); - } - } - break; - } - case t_doublefloat: { - double f = ecl_double_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= DBL_MIN_EXP) { - precision = DBL_MANT_DIG; - } else { - precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp); - } - } - break; - } + const cl_env_ptr the_env = ecl_process_env(); + int precision; + switch (ecl_t_of(x)) { + case t_singlefloat: { + float f = ecl_single_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexpf(f, &exp); + if (exp >= FLT_MIN_EXP) { + precision = FLT_MANT_DIG; + } else { + precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp); + } + } + break; + } + case t_doublefloat: { + double f = ecl_double_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexp(f, &exp); + if (exp >= DBL_MIN_EXP) { + precision = DBL_MANT_DIG; + } else { + precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp); + } + } + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double f = ecl_long_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= LDBL_MIN_EXP) { - precision = LDBL_MANT_DIG; - } else { - precision = LDBL_MANT_DIG - (LDBL_MIN_EXP - exp); - } - } - break; - } + case t_longfloat: { + long double f = ecl_long_float(x); + if (f == 0.0) { + precision = 0; + } else { + int exp; + frexp(f, &exp); + if (exp >= LDBL_MIN_EXP) { + precision = LDBL_MANT_DIG; + } else { + precision = LDBL_MANT_DIG - (LDBL_MIN_EXP - exp); + } + } + break; + } #endif - default: - FEwrong_type_nth_arg(@[float-precision],1,x,@[float]); - } - ecl_return1(the_env, ecl_make_fixnum(precision)); + default: + FEwrong_type_nth_arg(@[float-precision],1,x,@[float]); + } + ecl_return1(the_env, ecl_make_fixnum(precision)); } cl_object cl_integer_decode_float(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - int e, s = 1; + const cl_env_ptr the_env = ecl_process_env(); + int e, s = 1; - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); + case t_longfloat: { + long double d = ecl_long_float(x); if (signbit(d)) { s = -1; d = -d; } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { d = frexpl(d, &e); - x = _ecl_long_double_to_integer(ldexpl(d, LDBL_MANT_DIG)); - e -= LDBL_MANT_DIG; - } - break; - } + x = _ecl_long_double_to_integer(ldexpl(d, LDBL_MANT_DIG)); + e -= LDBL_MANT_DIG; + } + break; + } #endif - case t_doublefloat: { - double d = ecl_double_float(x); + case t_doublefloat: { + double d = ecl_double_float(x); if (signbit(d)) { s = -1; d = -d; } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { d = frexp(d, &e); - x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); - e -= DBL_MANT_DIG; - } - break; - } - case t_singlefloat: { - float d = ecl_single_float(x); + x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); + e -= DBL_MANT_DIG; + } + break; + } + case t_singlefloat: { + float d = ecl_single_float(x); if (signbit(d)) { s = -1; d = -d; } - if (d == 0.0) { - e = 0; - x = ecl_make_fixnum(0); - } else { + if (d == 0.0) { + e = 0; + x = ecl_make_fixnum(0); + } else { d = frexpf(d, &e); - x = _ecl_double_to_integer(ldexp(d, FLT_MANT_DIG)); - e -= FLT_MANT_DIG; - } - break; - } - default: - FEwrong_type_nth_arg(@[integer-decode-float],1,x,@[float]); - } - ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_fixnum(s)); + x = _ecl_double_to_integer(ldexp(d, FLT_MANT_DIG)); + e -= FLT_MANT_DIG; + } + break; + } + default: + FEwrong_type_nth_arg(@[integer-decode-float],1,x,@[float]); + } + ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_fixnum(s)); } @(defun complex (r &optional (i ecl_make_fixnum(0))) -@ /* INV: ecl_make_complex() checks types */ - @(return ecl_make_complex(r, i)) +@ /* INV: ecl_make_complex() checks types */ + @(return ecl_make_complex(r, i)) @) cl_object cl_realpart(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - break; - case t_complex: - x = x->complex.real; - break; - default: - FEwrong_type_nth_arg(@[realpart],1,x,@[number]); - } - @(return x) + break; + case t_complex: + x = x->complex.real; + break; + default: + FEwrong_type_nth_arg(@[realpart],1,x,@[number]); + } + @(return x) } cl_object cl_imagpart(cl_object x) { - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - x = ecl_make_fixnum(0); - break; - case t_singlefloat: + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + x = ecl_make_fixnum(0); + break; + case t_singlefloat: if (signbit(ecl_single_float(x))) x = cl_core.singlefloat_minus_zero; else x = cl_core.singlefloat_zero; - break; - case t_doublefloat: + break; + case t_doublefloat: if (signbit(ecl_double_float(x))) x = cl_core.doublefloat_minus_zero; else x = cl_core.doublefloat_zero; - break; + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: if (signbit(ecl_long_float(x))) x = cl_core.longfloat_minus_zero; else x = cl_core.longfloat_zero; - break; + break; #endif - case t_complex: - x = x->complex.imag; - break; - default: + case t_complex: + x = x->complex.imag; + break; + default: FEwrong_type_nth_arg(@[imagpart],1,x,@[number]); - } - @(return x) + } + @(return x) } diff --git a/src/c/num_log.d b/src/c/num_log.d index a070dbd96..957c4156f 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -26,214 +26,214 @@ static cl_fixnum ior_op(cl_fixnum i, cl_fixnum j) { - return(i | j); + return(i | j); } static cl_fixnum xor_op(cl_fixnum i, cl_fixnum j) { - return(i ^ j); + return(i ^ j); } static cl_fixnum and_op(cl_fixnum i, cl_fixnum j) { - return(i & j); + return(i & j); } static cl_fixnum eqv_op(cl_fixnum i, cl_fixnum j) { - return(~(i ^ j)); + return(~(i ^ j)); } static cl_fixnum nand_op(cl_fixnum i, cl_fixnum j) { - return(~(i & j)); + return(~(i & j)); } static cl_fixnum nor_op(cl_fixnum i, cl_fixnum j) { - return(~(i | j)); + return(~(i | j)); } static cl_fixnum andc1_op(cl_fixnum i, cl_fixnum j) { - return((~i) & j); + return((~i) & j); } static cl_fixnum andc2_op(cl_fixnum i, cl_fixnum j) { - return(i & (~j)); + return(i & (~j)); } static cl_fixnum orc1_op(cl_fixnum i, cl_fixnum j) { - return((~i) | j); + return((~i) | j); } static cl_fixnum orc2_op(cl_fixnum i, cl_fixnum j) { - return(i | (~j)); + return(i | (~j)); } static cl_fixnum b_clr_op(cl_fixnum i, cl_fixnum j) { - return(0); + return(0); } static cl_fixnum b_set_op(cl_fixnum i, cl_fixnum j) { - return(-1); + return(-1); } static cl_fixnum b_1_op(cl_fixnum i, cl_fixnum j) { - return(i); + return(i); } static cl_fixnum b_2_op(cl_fixnum i, cl_fixnum j) { - return(j); + return(j); } static cl_fixnum b_c1_op(cl_fixnum i, cl_fixnum j) { - return(~i); + return(~i); } static cl_fixnum b_c2_op(cl_fixnum i, cl_fixnum j) { - return(~j); + return(~j); } typedef cl_fixnum (*bit_operator)(cl_fixnum, cl_fixnum); static bit_operator fixnum_operations[16] = { - b_clr_op, - and_op, - andc2_op, - b_1_op, - andc1_op, - b_2_op, - xor_op, - ior_op, - nor_op, - eqv_op, - b_c2_op, - orc2_op, - b_c1_op, - orc1_op, - nand_op, - b_set_op}; + b_clr_op, + and_op, + andc2_op, + b_1_op, + andc1_op, + b_2_op, + xor_op, + ior_op, + nor_op, + eqv_op, + b_c2_op, + orc2_op, + b_c1_op, + orc1_op, + nand_op, + b_set_op}; static cl_object log_op(cl_narg narg, int op, ecl_va_list ARGS) { - cl_object x, y; - /* FIXME! This can be optimized */ - x = ecl_va_arg(ARGS); - if (narg-- == 1) { - assert_type_integer(x); - } else { - do { - y = ecl_va_arg(ARGS); - x = ecl_boole(op, x, y); - } while (--narg); - } - return x; + cl_object x, y; + /* FIXME! This can be optimized */ + x = ecl_va_arg(ARGS); + if (narg-- == 1) { + assert_type_integer(x); + } else { + do { + y = ecl_va_arg(ARGS); + x = ecl_boole(op, x, y); + } while (--narg); + } + return x; } cl_object ecl_boole(int op, cl_object x, cl_object y) { - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: { - cl_fixnum z = fixnum_operations[op](ecl_fixnum(x), ecl_fixnum(y)); - return ecl_make_fixnum(z); - } - case t_bignum: { + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: { + cl_fixnum z = fixnum_operations[op](ecl_fixnum(x), ecl_fixnum(y)); + return ecl_make_fixnum(z); + } + case t_bignum: { cl_object x_copy = _ecl_big_register0(); _ecl_big_set_fixnum(x_copy, ecl_fixnum(x)); (_ecl_big_boole_operator(op))(x_copy, x_copy, y); return _ecl_big_register_normalize(x_copy); - } - default: + } + default: FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); - } - break; - case t_bignum: { + } + break; + case t_bignum: { cl_object x_copy = _ecl_big_register0(); - switch (ecl_t_of(y)) { - case t_fixnum: { - cl_object z = _ecl_big_register1(); + switch (ecl_t_of(y)) { + case t_fixnum: { + cl_object z = _ecl_big_register1(); _ecl_big_set_fixnum(z,ecl_fixnum(y)); (_ecl_big_boole_operator(op))(x_copy, x, z); - _ecl_big_register_free(z); - break; - } - case t_bignum: - (_ecl_big_boole_operator(op))(x_copy, x, y); - break; - default: + _ecl_big_register_free(z); + break; + } + case t_bignum: + (_ecl_big_boole_operator(op))(x_copy, x, y); + break; + default: FEwrong_type_nth_arg(@[boole], 2, y, @[integer]); - } + } return _ecl_big_register_normalize(x_copy); - } - default: + } + default: FEwrong_type_nth_arg(@[boole], 1, x, @[integer]); - } - return x; + } + return x; } cl_object cl_lognot(cl_object x) { - return @logxor(2,x,ecl_make_fixnum(-1)); + return @logxor(2,x,ecl_make_fixnum(-1)); } static cl_fixnum count_bits(cl_object x) { - cl_fixnum count; + cl_fixnum count; - switch (ecl_t_of(x)) { - case t_fixnum: { - cl_fixnum i = ecl_fixnum(x); - cl_fixnum j = (i < 0) ? ~i : i; - for (count=0 ; j ; j >>= 1) - if (j & 1) count++; - break; - } - case t_bignum: - if (_ecl_big_sign(x) >= 0) - count = mpz_popcount(x->big.big_num); - else { - cl_object z = _ecl_big_register0(); - mpz_com(z->big.big_num, x->big.big_num); - count = mpz_popcount(z->big.big_num); - _ecl_big_register_free(z); - } - break; - default: + switch (ecl_t_of(x)) { + case t_fixnum: { + cl_fixnum i = ecl_fixnum(x); + cl_fixnum j = (i < 0) ? ~i : i; + for (count=0 ; j ; j >>= 1) + if (j & 1) count++; + break; + } + case t_bignum: + if (_ecl_big_sign(x) >= 0) + count = mpz_popcount(x->big.big_num); + else { + cl_object z = _ecl_big_register0(); + mpz_com(z->big.big_num, x->big.big_num); + count = mpz_popcount(z->big.big_num); + _ecl_big_register_free(z); + } + break; + default: FEwrong_type_only_arg(@[logcount], x, @[integer]); - } - return count; + } + return count; } /* @@ -242,394 +242,394 @@ count_bits(cl_object x) cl_object ecl_ash(cl_object x, cl_fixnum w) { - cl_object y; + cl_object y; - if (w == 0) - return(x); - y = _ecl_big_register0(); - if (w < 0) { - cl_index bits = -w; - if (ECL_FIXNUMP(x)) { - /* The result of shifting a number further than the number - * of digits it has is unpredictable in C. For instance, GCC - * on intel masks out all bits of "bits" beyond the 5 and - * it may happen that a shift of 37 becomes a shift of 5. - * Furthermore, in general, shifting negative numbers leads - * to implementation-specific results :-/ - */ - cl_fixnum y = ecl_fixnum(x); - if (bits >= FIXNUM_BITS) { - y = (y < 0)? -1 : 0; - } else { - y >>= bits; - } - return ecl_make_fixnum(y); - } - mpz_div_2exp(y->big.big_num, x->big.big_num, bits); - } else { - if (ECL_FIXNUMP(x)) { - _ecl_big_set_fixnum(y, ecl_fixnum(x)); - x = y; - } - mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w); - } - return _ecl_big_register_normalize(y); + if (w == 0) + return(x); + y = _ecl_big_register0(); + if (w < 0) { + cl_index bits = -w; + if (ECL_FIXNUMP(x)) { + /* The result of shifting a number further than the number + * of digits it has is unpredictable in C. For instance, GCC + * on intel masks out all bits of "bits" beyond the 5 and + * it may happen that a shift of 37 becomes a shift of 5. + * Furthermore, in general, shifting negative numbers leads + * to implementation-specific results :-/ + */ + cl_fixnum y = ecl_fixnum(x); + if (bits >= FIXNUM_BITS) { + y = (y < 0)? -1 : 0; + } else { + y >>= bits; + } + return ecl_make_fixnum(y); + } + mpz_div_2exp(y->big.big_num, x->big.big_num, bits); + } else { + if (ECL_FIXNUMP(x)) { + _ecl_big_set_fixnum(y, ecl_fixnum(x)); + x = y; + } + mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w); + } + return _ecl_big_register_normalize(y); } int ecl_fixnum_bit_length(cl_fixnum i) { - int count; - if (i < 0) - i = ~i; - for (count = 0; i && (count < FIXNUM_BITS); i >>= 1, count++) - ; - return count; + int count; + if (i < 0) + i = ~i; + for (count = 0; i && (count < FIXNUM_BITS); i >>= 1, count++) + ; + return count; } @(defun logior (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLIOR, nums)) + if (narg == 0) + @(return ecl_make_fixnum(0)) + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLIOR, nums)) @) @(defun logxor (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(0)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLXOR, nums)) + if (narg == 0) + @(return ecl_make_fixnum(0)) + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLXOR, nums)) @) @(defun logand (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(-1)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLAND, nums)) + if (narg == 0) + @(return ecl_make_fixnum(-1)) + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLAND, nums)) @) @(defun logeqv (&rest nums) @ - if (narg == 0) - @(return ecl_make_fixnum(-1)) - /* INV: log_op() checks types and outputs first argument as default. */ - @(return log_op(narg, ECL_BOOLEQV, nums)) + if (narg == 0) + @(return ecl_make_fixnum(-1)) + /* INV: log_op() checks types and outputs first argument as default. */ + @(return log_op(narg, ECL_BOOLEQV, nums)) @) cl_object cl_lognand(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLNAND, x, y)) + @(return ecl_boole(ECL_BOOLNAND, x, y)) } cl_object cl_lognor(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLNOR, x, y)) + @(return ecl_boole(ECL_BOOLNOR, x, y)) } cl_object cl_logandc1(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLANDC1, x, y)) + @(return ecl_boole(ECL_BOOLANDC1, x, y)) } cl_object cl_logandc2(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLANDC2, x, y)) + @(return ecl_boole(ECL_BOOLANDC2, x, y)) } cl_object cl_logorc1(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLORC1, x, y)) + @(return ecl_boole(ECL_BOOLORC1, x, y)) } cl_object cl_logorc2(cl_object x, cl_object y) { - @(return ecl_boole(ECL_BOOLORC2, x, y)) + @(return ecl_boole(ECL_BOOLORC2, x, y)) } static int coerce_to_logical_operator(cl_object o) { - cl_fixnum op; - op = ecl_to_fix(o); - if (op < 0 || op > ECL_BOOLSET) - FEerror("~S is an invalid logical operator.", 1, o); - return op; + cl_fixnum op; + op = ecl_to_fix(o); + if (op < 0 || op > ECL_BOOLSET) + FEerror("~S is an invalid logical operator.", 1, o); + return op; } cl_object cl_boole(cl_object o, cl_object x, cl_object y) { - /* INV: log_op2() checks types */ - @(return ecl_boole(coerce_to_logical_operator(o), x, y)) + /* INV: log_op2() checks types */ + @(return ecl_boole(coerce_to_logical_operator(o), x, y)) } cl_object cl_logbitp(cl_object p, cl_object x) { - bool i; + bool i; - assert_type_integer(x); - if (ECL_FIXNUMP(p)) { - cl_index n = ecl_to_size(p); - if (ECL_FIXNUMP(x)) { - cl_fixnum y = ecl_fixnum(x); - if (n >= FIXNUM_BITS) { - i = (y < 0); - } else { - i = ((y >> n) & 1); - } - } else { - i = mpz_tstbit(x->big.big_num, n); - } - } else { - assert_type_non_negative_integer(p); - if (ECL_FIXNUMP(x)) - i = (ecl_fixnum(x) < 0); - else - i = (_ecl_big_sign(x) < 0); - } - @(return (i ? ECL_T : ECL_NIL)) + assert_type_integer(x); + if (ECL_FIXNUMP(p)) { + cl_index n = ecl_to_size(p); + if (ECL_FIXNUMP(x)) { + cl_fixnum y = ecl_fixnum(x); + if (n >= FIXNUM_BITS) { + i = (y < 0); + } else { + i = ((y >> n) & 1); + } + } else { + i = mpz_tstbit(x->big.big_num, n); + } + } else { + assert_type_non_negative_integer(p); + if (ECL_FIXNUMP(x)) + i = (ecl_fixnum(x) < 0); + else + i = (_ecl_big_sign(x) < 0); + } + @(return (i ? ECL_T : ECL_NIL)) } cl_object cl_ash(cl_object x, cl_object y) { - cl_object r; - int sign_x; + cl_object r; + int sign_x; assert_type_integer(x); - assert_type_integer(y); - if (ECL_FIXNUMP(y)) - r = ecl_ash(x, ecl_fixnum(y)); - else { - /* - bit position represented by bignum is probably - out of our address space. So, result is returned - according to sign of integer. - */ - if (ECL_FIXNUMP(x)) - if (ecl_fixnum_minusp(x)) - sign_x = -1; - else if (x == ecl_make_fixnum(0)) - sign_x = 0; - else - sign_x = 1; - else - sign_x = _ecl_big_sign(x); - if (_ecl_big_sign(y) < 0) - if (sign_x < 0) - r = ecl_make_fixnum(-1); - else - r = ecl_make_fixnum(0); - else if (sign_x == 0) - r = x; - else - FEerror("Insufficient memory.", 0); - } - @(return r) + assert_type_integer(y); + if (ECL_FIXNUMP(y)) + r = ecl_ash(x, ecl_fixnum(y)); + else { + /* + bit position represented by bignum is probably + out of our address space. So, result is returned + according to sign of integer. + */ + if (ECL_FIXNUMP(x)) + if (ecl_fixnum_minusp(x)) + sign_x = -1; + else if (x == ecl_make_fixnum(0)) + sign_x = 0; + else + sign_x = 1; + else + sign_x = _ecl_big_sign(x); + if (_ecl_big_sign(y) < 0) + if (sign_x < 0) + r = ecl_make_fixnum(-1); + else + r = ecl_make_fixnum(0); + else if (sign_x == 0) + r = x; + else + FEerror("Insufficient memory.", 0); + } + @(return r) } cl_object cl_logcount(cl_object x) { - @(return ecl_make_fixnum(count_bits(x))) + @(return ecl_make_fixnum(count_bits(x))) } cl_index ecl_integer_length(cl_object x) { - int count; - cl_fixnum i; + int count; + cl_fixnum i; - switch (ecl_t_of(x)) { - case t_fixnum: - i = ecl_fixnum(x); - count = ecl_fixnum_bit_length(i); - break; - case t_bignum: - if (_ecl_big_sign(x) < 0) - x = cl_lognot(x); - count = mpz_sizeinbase(x->big.big_num, 2); - break; - default: + switch (ecl_t_of(x)) { + case t_fixnum: + i = ecl_fixnum(x); + count = ecl_fixnum_bit_length(i); + break; + case t_bignum: + if (_ecl_big_sign(x) < 0) + x = cl_lognot(x); + count = mpz_sizeinbase(x->big.big_num, 2); + break; + default: FEwrong_type_only_arg(@[integer-length], x, @[integer]); - } - return count; + } + return count; } cl_object cl_integer_length(cl_object x) { - @(return ecl_make_fixnum(ecl_integer_length(x))) + @(return ecl_make_fixnum(ecl_integer_length(x))) } cl_object si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r) { - cl_fixnum i, j, n, d; - cl_object r0; - bit_operator op; - bool replace = FALSE; - int xi, yi, ri; - byte *xp, *yp, *rp; - int xo, yo, ro; + cl_fixnum i, j, n, d; + cl_object r0; + bit_operator op; + bool replace = FALSE; + int xi, yi, ri; + byte *xp, *yp, *rp; + int xo, yo, ro; - if (ecl_t_of(x) == t_bitvector) { - d = x->vector.dim; - xp = x->vector.self.bit; - xo = x->vector.offset; - if (ecl_t_of(y) != t_bitvector) - goto ERROR; - if (d != y->vector.dim) - goto ERROR; - yp = y->vector.self.bit; - yo = y->vector.offset; - if (r == ECL_T) - r = x; - if (r != ECL_NIL) { - if (ecl_t_of(r) != t_bitvector) - goto ERROR; - if (r->vector.dim != d) - goto ERROR; - i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - goto L1; - } - i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - } - } - L1: - if (Null(r)) { - r = ecl_alloc_simple_vector(d, ecl_aet_bit); - } - } else { - if (ecl_t_of(x) != t_array) - goto ERROR; - if ((cl_elttype)x->array.elttype != ecl_aet_bit) - goto ERROR; - d = x->array.dim; - xp = x->vector.self.bit; - xo = x->vector.offset; - if (ecl_t_of(y) != t_array) - goto ERROR; - if ((cl_elttype)y->array.elttype != ecl_aet_bit) - goto ERROR; - if (x->array.rank != y->array.rank) - goto ERROR; - yp = y->vector.self.bit; - yo = y->vector.offset; - for (i = 0; i < x->array.rank; i++) - if (x->array.dims[i] != y->array.dims[i]) - goto ERROR; - if (r == ECL_T) - r = x; - if (r != ECL_NIL) { - if (ecl_t_of(r) != t_array) - goto ERROR; - if ((cl_elttype)r->array.elttype != ecl_aet_bit) - goto ERROR; - if (r->array.rank != x->array.rank) - goto ERROR; - for (i = 0; i < x->array.rank; i++) - if (r->array.dims[i] != x->array.dims[i]) - goto ERROR; - i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - goto L2; - } - i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); - if ((i > 0 && i < d) || (i < 0 && -i < d)) { - r0 = r; - r = ECL_NIL; - replace = TRUE; - } - } - L2: - if (Null(r)) { - r = ecl_alloc_object(t_array); - r->array.self.t = NULL; - r->array.displaced = ECL_NIL; - r->array.rank = x->array.rank; - r->array.dims = x->array.dims; - r->array.elttype = ecl_aet_bit; - r->array.dim = x->array.dim; - r->array.flags = 0; /* no fill pointer, not adjustable */ - ecl_array_allocself(r); - } - } - rp = r->vector.self.bit; - ro = r->vector.offset; - op = fixnum_operations[coerce_to_logical_operator(o)]; + if (ecl_t_of(x) == t_bitvector) { + d = x->vector.dim; + xp = x->vector.self.bit; + xo = x->vector.offset; + if (ecl_t_of(y) != t_bitvector) + goto ERROR; + if (d != y->vector.dim) + goto ERROR; + yp = y->vector.self.bit; + yo = y->vector.offset; + if (r == ECL_T) + r = x; + if (r != ECL_NIL) { + if (ecl_t_of(r) != t_bitvector) + goto ERROR; + if (r->vector.dim != d) + goto ERROR; + i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + goto L1; + } + i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + } + } + L1: + if (Null(r)) { + r = ecl_alloc_simple_vector(d, ecl_aet_bit); + } + } else { + if (ecl_t_of(x) != t_array) + goto ERROR; + if ((cl_elttype)x->array.elttype != ecl_aet_bit) + goto ERROR; + d = x->array.dim; + xp = x->vector.self.bit; + xo = x->vector.offset; + if (ecl_t_of(y) != t_array) + goto ERROR; + if ((cl_elttype)y->array.elttype != ecl_aet_bit) + goto ERROR; + if (x->array.rank != y->array.rank) + goto ERROR; + yp = y->vector.self.bit; + yo = y->vector.offset; + for (i = 0; i < x->array.rank; i++) + if (x->array.dims[i] != y->array.dims[i]) + goto ERROR; + if (r == ECL_T) + r = x; + if (r != ECL_NIL) { + if (ecl_t_of(r) != t_array) + goto ERROR; + if ((cl_elttype)r->array.elttype != ecl_aet_bit) + goto ERROR; + if (r->array.rank != x->array.rank) + goto ERROR; + for (i = 0; i < x->array.rank; i++) + if (r->array.dims[i] != x->array.dims[i]) + goto ERROR; + i = (r->vector.self.bit - xp)*8 + (r->vector.offset - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + goto L2; + } + i = (r->vector.self.bit - yp)*8 + (r->vector.offset - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = ECL_NIL; + replace = TRUE; + } + } + L2: + if (Null(r)) { + r = ecl_alloc_object(t_array); + r->array.self.t = NULL; + r->array.displaced = ECL_NIL; + r->array.rank = x->array.rank; + r->array.dims = x->array.dims; + r->array.elttype = ecl_aet_bit; + r->array.dim = x->array.dim; + r->array.flags = 0; /* no fill pointer, not adjustable */ + ecl_array_allocself(r); + } + } + rp = r->vector.self.bit; + ro = r->vector.offset; + op = fixnum_operations[coerce_to_logical_operator(o)]; -#define set_high(place, nbits, value) \ - (place)=((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits))) +#define set_high(place, nbits, value) \ + (place)=((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits))) -#define set_low(place, nbits, value) \ - (place)=((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits)))) +#define set_low(place, nbits, value) \ + (place)=((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits)))) -#define extract_byte(integer, pointer, index, offset) \ - (integer) = (pointer)[(index)+1] & 0377; \ - (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset))) +#define extract_byte(integer, pointer, index, offset) \ + (integer) = (pointer)[(index)+1] & 0377; \ + (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset))) -#define store_byte(pointer, index, offset, value) \ - set_low((pointer)[index], 8-(offset), (value)>>(offset)); \ - set_high((pointer)[(index)+1], offset, (value)<<(8-(offset))) +#define store_byte(pointer, index, offset, value) \ + set_low((pointer)[index], 8-(offset), (value)>>(offset)); \ + set_high((pointer)[(index)+1], offset, (value)<<(8-(offset))) - if (xo == 0 && yo == 0 && ro == 0) { - for (n = d/8, i = 0; i < n; i++) - rp[i] = (*op)(xp[i], yp[i]); - if ((j = d%8) > 0) - set_high(rp[n], j, (*op)(xp[n], yp[n])); - if (!replace) - @(return r) - } else { - for (n = d/8, i = 0; i <= n; i++) { - extract_byte(xi, xp, i, xo); - extract_byte(yi, yp, i, yo); - if (i == n) { - if ((j = d%8) == 0) - break; - extract_byte(ri, rp, n, ro); - set_high(ri, j, (*op)(xi, yi)); - } else - ri = (*op)(xi, yi); - store_byte(rp, i, ro, ri); - } - if (!replace) - @(return r) - } - rp = r0->vector.self.bit; - ro = r0->vector.offset; - for (n = d/8, i = 0; i <= n; i++) { - if (i == n) { - if ((j = d%8) == 0) - break; - extract_byte(ri, rp, n, ro); - set_high(ri, j, r->vector.self.bit[n]); - } else - ri = r->vector.self.bit[i]; - store_byte(rp, i, ro, ri); - } - @(return r0) + if (xo == 0 && yo == 0 && ro == 0) { + for (n = d/8, i = 0; i < n; i++) + rp[i] = (*op)(xp[i], yp[i]); + if ((j = d%8) > 0) + set_high(rp[n], j, (*op)(xp[n], yp[n])); + if (!replace) + @(return r) + } else { + for (n = d/8, i = 0; i <= n; i++) { + extract_byte(xi, xp, i, xo); + extract_byte(yi, yp, i, yo); + if (i == n) { + if ((j = d%8) == 0) + break; + extract_byte(ri, rp, n, ro); + set_high(ri, j, (*op)(xi, yi)); + } else + ri = (*op)(xi, yi); + store_byte(rp, i, ro, ri); + } + if (!replace) + @(return r) + } + rp = r0->vector.self.bit; + ro = r0->vector.offset; + for (n = d/8, i = 0; i <= n; i++) { + if (i == n) { + if ((j = d%8) == 0) + break; + extract_byte(ri, rp, n, ro); + set_high(ri, j, r->vector.self.bit[n]); + } else + ri = r->vector.self.bit[i]; + store_byte(rp, i, ro, ri); + } + @(return r0) ERROR: - FEerror("Illegal arguments for bit-array operation.", 0); + FEerror("Illegal arguments for bit-array operation.", 0); } diff --git a/src/c/num_pred.d b/src/c/num_pred.d index f0cd409e8..47ef042c1 100644 --- a/src/c/num_pred.d +++ b/src/c/num_pred.d @@ -23,9 +23,9 @@ int ecl_oddp(cl_object x) { - if (ECL_FIXNUMP(x)) - return ecl_fixnum(x) & 1; - unlikely_if (!ECL_BIGNUMP(x)) + if (ECL_FIXNUMP(x)) + return ecl_fixnum(x) & 1; + unlikely_if (!ECL_BIGNUMP(x)) FEwrong_type_only_arg(@[oddp], x, @[integer]); return _ecl_big_odd_p(x); } @@ -33,56 +33,56 @@ ecl_oddp(cl_object x) int ecl_evenp(cl_object x) { - if (ECL_FIXNUMP(x)) - return ~ecl_fixnum(x) & 1; - unlikely_if (!ECL_BIGNUMP(x)) + if (ECL_FIXNUMP(x)) + return ~ecl_fixnum(x) & 1; + unlikely_if (!ECL_BIGNUMP(x)) FEwrong_type_only_arg(@[evenp], x, @[integer]); return _ecl_big_even_p(x); } cl_object cl_oddp(cl_object x) -{ /* INV: ecl_oddp() checks type */ - @(return (ecl_oddp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_oddp() checks type */ + @(return (ecl_oddp(x) ? ECL_T : ECL_NIL)) } cl_object cl_evenp(cl_object x) -{ /* INV: ecl_evenp() checks_type */ - @(return (ecl_evenp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_evenp() checks_type */ + @(return (ecl_evenp(x) ? ECL_T : ECL_NIL)) } cl_object si_float_nan_p(cl_object x) { - @(return (ecl_float_nan_p(x)? ECL_T : ECL_NIL)) + @(return (ecl_float_nan_p(x)? ECL_T : ECL_NIL)) } cl_object si_float_infinity_p(cl_object x) { - @(return (ecl_float_infinity_p(x)? ECL_T : ECL_NIL)) + @(return (ecl_float_infinity_p(x)? ECL_T : ECL_NIL)) } bool ecl_float_nan_p(cl_object x) { - return !ecl_number_equalp(x,x); + return !ecl_number_equalp(x,x); } bool ecl_float_infinity_p(cl_object x) { - switch (ecl_t_of(x)) { - case t_singlefloat: - return !isfinite(ecl_single_float(x)); - case t_doublefloat: - return !isfinite(ecl_double_float(x)); + switch (ecl_t_of(x)) { + case t_singlefloat: + return !isfinite(ecl_single_float(x)); + case t_doublefloat: + return !isfinite(ecl_double_float(x)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return !isfinite(ecl_long_float(x)); + case t_longfloat: + return !isfinite(ecl_long_float(x)); #endif - default: - return 0; - } + default: + return 0; + } } diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 45a540137..89eb2bbde 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -38,19 +38,19 @@ cl_object init_random_state() { - return (cl_object)time(0); + return (cl_object)time(0); } static double generate_double(cl_object rs) { - rs->random.value - = rs->random.value - + (rs->random.value<<2) - + (rs->random.value<<17) - + (rs->random.value<<27); - rs->random.value = rs->random.value & 0xffffffff; - return (double)(rs->random.value>>1) / (4294967296.0/2.0); + rs->random.value + = rs->random.value + + (rs->random.value<<2) + + (rs->random.value<<17) + + (rs->random.value<<27); + rs->random.value = rs->random.value & 0xffffffff; + return (double)(rs->random.value>>1) / (4294967296.0/2.0); } #else @@ -71,73 +71,73 @@ generate_double(cl_object rs) cl_object init_random_state() { - cl_index bytes = sizeof(ulong) * (MT_N + 1); - cl_object a = ecl_alloc_simple_base_string(bytes); - ulong *mt = (ulong*)a->base_string.self; - int j = 0; + cl_index bytes = sizeof(ulong) * (MT_N + 1); + cl_object a = ecl_alloc_simple_base_string(bytes); + ulong *mt = (ulong*)a->base_string.self; + int j = 0; #if !defined(ECL_MS_WINDOWS_HOST) - /* fopen() might read full 4kB blocks and discard - * a lot of entropy, so use open() */ - int fh = open("/dev/urandom", O_RDONLY); - char buffer[16]; - if (fh != -1) { - j = read(fh, buffer, sizeof(buffer)); - for (; j < sizeof(buffer) && j < MT_N; j++){ - mt[j] = buffer[j]; - } - close(fh); - } -#endif - { - /* cant get urandom, use crappy source */ - /* and/or fill rest of area */ - mt[j++] = (rand() + time(0)) & 0xffffffffUL; - for (; j < MT_N; j++){ - mt[j] = (1812433253UL * (mt[j-1] ^ (mt[j-1] >> 30)) + j); - if (j >= 16) - mt[j] ^= mt[j-16]; - mt[j] &= 0xffffffffUL; - } - } - mt[MT_N] = MT_N+1; - return a; + /* fopen() might read full 4kB blocks and discard + * a lot of entropy, so use open() */ + int fh = open("/dev/urandom", O_RDONLY); + char buffer[16]; + if (fh != -1) { + j = read(fh, buffer, sizeof(buffer)); + for (; j < sizeof(buffer) && j < MT_N; j++){ + mt[j] = buffer[j]; + } + close(fh); + } +#endif + { + /* cant get urandom, use crappy source */ + /* and/or fill rest of area */ + mt[j++] = (rand() + time(0)) & 0xffffffffUL; + for (; j < MT_N; j++){ + mt[j] = (1812433253UL * (mt[j-1] ^ (mt[j-1] >> 30)) + j); + if (j >= 16) + mt[j] ^= mt[j-16]; + mt[j] &= 0xffffffffUL; + } + } + mt[MT_N] = MT_N+1; + return a; } ulong generate_int32(cl_object state) { - static ulong mag01[2]={0x0UL, MATRIX_A}; - ulong y; - ulong *mt = (ulong*)state->base_string.self; - if (mt[MT_N] >= MT_N){ - /* refresh data */ - int kk; - for (kk=0; kk < (MT_N - MT_M); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1UL]; - } - for (; kk < (MT_N - 1); kk++) { - y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); - mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1UL]; - } - y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); - mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1UL]; - mt[MT_N] = 0; - } - /* get random 32 bit num */ - y = mt[mt[MT_N]++]; - /* Tempering */ - y ^= (y >> 11); - y ^= (y << 7) & 0x9d2c5680UL; - y ^= (y << 15) & 0xefc60000UL; - y ^= (y >> 18); - return y; + static ulong mag01[2]={0x0UL, MATRIX_A}; + ulong y; + ulong *mt = (ulong*)state->base_string.self; + if (mt[MT_N] >= MT_N){ + /* refresh data */ + int kk; + for (kk=0; kk < (MT_N - MT_M); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk + MT_M] ^ (y >> 1) ^ mag01[y & 0x1UL]; + } + for (; kk < (MT_N - 1); kk++) { + y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK); + mt[kk] = mt[kk+(MT_M-MT_N)] ^ (y >> 1) ^ mag01[y & 0x1UL]; + } + y = (mt[MT_N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK); + mt[MT_N-1] = mt[MT_M-1] ^ (y >> 1) ^ mag01[y & 0x1UL]; + mt[MT_N] = 0; + } + /* get random 32 bit num */ + y = mt[mt[MT_N]++]; + /* Tempering */ + y ^= (y >> 11); + y ^= (y << 7) & 0x9d2c5680UL; + y ^= (y << 15) & 0xefc60000UL; + y ^= (y >> 18); + return y; } static double generate_double(cl_object state) { - return generate_int32(state) * (1.0 / 4294967296.0); + return generate_int32(state) * (1.0 / 4294967296.0); } #endif @@ -181,73 +181,73 @@ random_integer(cl_object limit, cl_object state) static cl_object rando(cl_object x, cl_object rs) { - cl_object z; - if (!ecl_plusp(x)) { - goto ERROR; - } - switch (ecl_t_of(x)) { - case t_fixnum: + cl_object z; + if (!ecl_plusp(x)) { + goto ERROR; + } + switch (ecl_t_of(x)) { + case t_fixnum: #if FIXNUM_BITS <= 32 z = ecl_make_fixnum(generate_int32(rs->random.value) % ecl_fixnum(x)); break; #endif - case t_bignum: - z = random_integer(x, rs->random.value); - break; - case t_singlefloat: - z = ecl_make_single_float(ecl_single_float(x) * + case t_bignum: + z = random_integer(x, rs->random.value); + break; + case t_singlefloat: + z = ecl_make_single_float(ecl_single_float(x) * (float)generate_double(rs->random.value)); - break; - case t_doublefloat: - z = ecl_make_double_float(ecl_double_float(x) * + break; + case t_doublefloat: + z = ecl_make_double_float(ecl_double_float(x) * generate_double(rs->random.value)); - break; + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - z = ecl_make_long_float(ecl_long_float(x) * + case t_longfloat: + z = ecl_make_long_float(ecl_long_float(x) * (long double)generate_double(rs->random.value)); - break; + break; #endif - default: ERROR: { + default: ERROR: { const char *type = "(OR (INTEGER (0) *) (FLOAT (0) *))"; - FEwrong_type_nth_arg(@[random],1,x, ecl_read_from_cstring(type)); + FEwrong_type_nth_arg(@[random],1,x, ecl_read_from_cstring(type)); } - } - return z; + } + return z; } cl_object ecl_make_random_state(cl_object rs) { cl_object z = ecl_alloc_object(t_random); - if (rs == ECL_T) { - z->random.value = init_random_state(); - } else { - if (Null(rs)) { - rs = ecl_symbol_value(@'*random-state*'); - } - unlikely_if (!ECL_RANDOM_STATE_P(rs)) { - FEwrong_type_only_arg(@[make-random-state], rs, + if (rs == ECL_T) { + z->random.value = init_random_state(); + } else { + if (Null(rs)) { + rs = ecl_symbol_value(@'*random-state*'); + } + unlikely_if (!ECL_RANDOM_STATE_P(rs)) { + FEwrong_type_only_arg(@[make-random-state], rs, @[random-state]); - } - z->random.value = cl_copy_seq(rs->random.value); - } - return(z); + } + z->random.value = cl_copy_seq(rs->random.value); + } + return(z); } @(defun random (x &optional (rs ecl_symbol_value(@'*random-state*'))) @ - rs = ecl_check_cl_type(@'random', rs, t_random); - @(return rando(x, rs)); + rs = ecl_check_cl_type(@'random', rs, t_random); + @(return rando(x, rs)); @) @(defun make_random_state (&optional (rs ECL_NIL)) @ - @(return ecl_make_random_state(rs)) + @(return ecl_make_random_state(rs)) @) cl_object cl_random_state_p(cl_object x) { - @(return (ECL_RANDOM_STATE_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_RANDOM_STATE_P(x) ? ECL_T : ECL_NIL)) } diff --git a/src/c/number.d b/src/c/number.d index 9246ac160..d1144c93f 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -37,9 +37,9 @@ * X, where the status of the FPE control word is changed by * printf. We have two alternatives. */ -# define DO_DETECT_FPE(f) do { \ - unlikely_if (isnan(f)) ecl_deliver_fpe(FE_INVALID); \ - unlikely_if (!isfinite(f)) ecl_deliver_fpe(FE_OVERFLOW); \ +# define DO_DETECT_FPE(f) do { \ + unlikely_if (isnan(f)) ecl_deliver_fpe(FE_INVALID); \ + unlikely_if (!isfinite(f)) ecl_deliver_fpe(FE_OVERFLOW); \ } while (0) #endif @@ -47,44 +47,44 @@ cl_fixnum ecl_to_fix(cl_object f) { - if (ecl_unlikely(!ECL_FIXNUMP(f))) - FEtype_error_fixnum(f); - return ecl_fixnum(f); + if (ecl_unlikely(!ECL_FIXNUMP(f))) + FEtype_error_fixnum(f); + return ecl_fixnum(f); } cl_index ecl_to_size(cl_object f) { - cl_fixnum aux; - if (ecl_likely(ECL_FIXNUMP(f))) { - cl_fixnum aux = ecl_fixnum(f); - if (ecl_likely(aux >= 0)) - return aux; - } - FEtype_error_size(f); + cl_fixnum aux; + if (ecl_likely(ECL_FIXNUMP(f))) { + cl_fixnum aux = ecl_fixnum(f); + if (ecl_likely(aux >= 0)) + return aux; + } + FEtype_error_size(f); } #endif /* !ECL_CAN_INLINE */ cl_object ecl_make_integer(cl_fixnum l) { - if (l > MOST_POSITIVE_FIXNUM || l < MOST_NEGATIVE_FIXNUM) { + if (l > MOST_POSITIVE_FIXNUM || l < MOST_NEGATIVE_FIXNUM) { cl_object z = _ecl_big_register0(); _ecl_big_set_fixnum(z, l); return _ecl_big_register_copy(z); - } - return ecl_make_fixnum(l); + } + return ecl_make_fixnum(l); } cl_object ecl_make_unsigned_integer(cl_index l) { - if (l > MOST_POSITIVE_FIXNUM) { + if (l > MOST_POSITIVE_FIXNUM) { cl_object z = _ecl_big_register0(); _ecl_big_set_index(z, l); return _ecl_big_register_copy(z); - } - return ecl_make_fixnum(l); + } + return ecl_make_fixnum(l); } int @@ -96,55 +96,55 @@ ecl_to_bit(cl_object x) { ecl_uint8_t ecl_to_uint8_t(cl_object x) { - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum aux = ecl_fixnum(x); - if (ecl_likely(aux >= 0 && aux <= 255)) - return (ecl_uint8_t)aux; - } - FEwrong_type_argument(cl_list(2, @'unsigned-byte', ecl_make_fixnum(8)), - x); + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum aux = ecl_fixnum(x); + if (ecl_likely(aux >= 0 && aux <= 255)) + return (ecl_uint8_t)aux; + } + FEwrong_type_argument(cl_list(2, @'unsigned-byte', ecl_make_fixnum(8)), + x); } ecl_int8_t ecl_to_int8_t(cl_object x) { - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum aux = ecl_fixnum(x); - if (ecl_likely(aux >= -128 && aux <= 127)) - return (ecl_uint8_t)aux; - } - FEwrong_type_argument(cl_list(2, @'signed-byte', ecl_make_fixnum(8)), - x); + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum aux = ecl_fixnum(x); + if (ecl_likely(aux >= -128 && aux <= 127)) + return (ecl_uint8_t)aux; + } + FEwrong_type_argument(cl_list(2, @'signed-byte', ecl_make_fixnum(8)), + x); } unsigned short ecl_to_ushort(cl_object x) { - const unsigned short ushort_max = USHRT_MAX; + const unsigned short ushort_max = USHRT_MAX; if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= ushort_max)) { - return (unsigned short)y; + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= ushort_max)) { + return (unsigned short)y; } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(0), - ecl_make_fixnum(ushort_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(0), + ecl_make_fixnum(ushort_max)), + x); } short ecl_to_short(cl_object x) { - const short short_min = SHRT_MIN; - const short short_max = SHRT_MAX; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= short_min && y <= short_max)) { - return (short)y; + const short short_min = SHRT_MIN; + const short short_max = SHRT_MAX; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= short_min && y <= short_max)) { + return (short)y; } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(short_min), - ecl_make_fixnum(short_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(short_min), + ecl_make_fixnum(short_max)), + x); } #if FIXNUM_BITS < 32 @@ -154,117 +154,117 @@ ecl_to_short(cl_object x) { #ifdef ecl_uint16_t ecl_uint16_t ecl_to_uint16_t(cl_object x) { - const uint16_t uint16_max = 0xFFFFL; + const uint16_t uint16_max = 0xFFFFL; if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= uint16_max)) { - return (ecl_uint16_t)y; + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= uint16_max)) { + return (ecl_uint16_t)y; } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(0), - ecl_make_fixnum(uint16_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(0), + ecl_make_fixnum(uint16_max)), + x); } ecl_int16_t ecl_to_int16_t(cl_object x) { - const int16_t int16_min = -0x8000; - const int16_t int16_max = 0x7FFF; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= int16_min && y <= int16_max)) { - return (ecl_int16_t)y; + const int16_t int16_min = -0x8000; + const int16_t int16_max = 0x7FFF; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= int16_min && y <= int16_max)) { + return (ecl_int16_t)y; } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_fixnum(int16_min), - ecl_make_fixnum(int16_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_fixnum(int16_min), + ecl_make_fixnum(int16_max)), + x); } #endif /* ecl_uint16_t */ #if defined(ecl_uint32_t) && (FIXNUM_BITS > 32) ecl_uint32_t ecl_to_uint32_t(cl_object x) { - const uint32_t uint32_max = 0xFFFFFFFFUL; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= 0 && y <= uint32_max)) { - return (ecl_uint32_t)y; + const uint32_t uint32_max = 0xFFFFFFFFUL; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= 0 && y <= uint32_max)) { + return (ecl_uint32_t)y; } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_make_unsigned_integer(uint32_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_make_unsigned_integer(uint32_max)), + x); } ecl_int32_t ecl_to_int32_t(cl_object x) { - const int32_t int32_min = -0x80000000L; - const int32_t int32_max = 0x7FFFFFFFL; - if (ecl_likely(ECL_FIXNUMP(x))) { - cl_fixnum y = ecl_fixnum(x); - if (ecl_likely(y >= int32_min && y <= int32_max)) { - return (ecl_int32_t)y; + const int32_t int32_min = -0x80000000L; + const int32_t int32_max = 0x7FFFFFFFL; + if (ecl_likely(ECL_FIXNUMP(x))) { + cl_fixnum y = ecl_fixnum(x); + if (ecl_likely(y >= int32_min && y <= int32_max)) { + return (ecl_int32_t)y; } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_make_integer(int32_min), - ecl_make_integer(int32_max)), - x); + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_make_integer(int32_min), + ecl_make_integer(int32_max)), + x); } #endif /* ecl_uint32_t */ #if defined(ecl_uint64_t) && (FIXNUM_BITS < 64) ecl_uint64_t ecl_to_uint64_t(cl_object x) { - if (!ecl_minusp(x)) { - if (ECL_FIXNUMP(x)) { - return (ecl_uint64_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_ulong_p(x->big.big_num)) { - return (ecl_uint64_t)mpz_get_ui(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_uint64_t output; - output = (ecl_uint64_t)mpz_get_ui(copy->big.big_num); - output = (output << 32) + - (ecl_uint64_t)mpz_get_ui(x->big.big_num); - return output; - } - } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 64))), - x); + if (!ecl_minusp(x)) { + if (ECL_FIXNUMP(x)) { + return (ecl_uint64_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_ulong_p(x->big.big_num)) { + return (ecl_uint64_t)mpz_get_ui(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_uint64_t output; + output = (ecl_uint64_t)mpz_get_ui(copy->big.big_num); + output = (output << 32) + + (ecl_uint64_t)mpz_get_ui(x->big.big_num); + return output; + } + } + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 64))), + x); } ecl_int64_t ecl_to_int64_t(cl_object x) { - if (ECL_FIXNUMP(x)) { - return (ecl_int64_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_slong_p(x->big.big_num)) { - return (ecl_int64_t)mpz_get_si(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); - if (mpz_fits_slong_p(copy->big.big_num)) { - ecl_int64_t output; - output = (ecl_int64_t)mpz_get_si(copy->big.big_num); - mpz_fdiv_r_2exp(copy->big.big_num, x->big.big_num, 32); - return (output << 32) + mpz_get_ui(copy->big.big_num); - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_negate(ecl_ash(ecl_make_fixnum(1), 63)), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 63))), - x); + if (ECL_FIXNUMP(x)) { + return (ecl_int64_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_slong_p(x->big.big_num)) { + return (ecl_int64_t)mpz_get_si(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32); + if (mpz_fits_slong_p(copy->big.big_num)) { + ecl_int64_t output; + output = (ecl_int64_t)mpz_get_si(copy->big.big_num); + mpz_fdiv_r_2exp(copy->big.big_num, x->big.big_num, 32); + return (output << 32) + mpz_get_ui(copy->big.big_num); + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_negate(ecl_ash(ecl_make_fixnum(1), 63)), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 63))), + x); } cl_object @@ -333,61 +333,61 @@ ecl_make_long_long(ecl_long_long_t i) { # else ecl_ulong_long_t ecl_to_ulong_long(cl_object x) { - if (!ecl_minusp(x)) { - if (ECL_FIXNUMP(x)) { - return (ecl_ulong_long_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_ulong_p(x->big.big_num)) { - return (ecl_ulong_long_t)mpz_get_ui(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - int i = ECL_LONG_LONG_BITS - FIXNUM_BITS; - mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_ulong_long_t output; - output = mpz_get_ui(copy->big.big_num); - for (i -= FIXNUM_BITS; i; i-= FIXNUM_BITS) { - output = (output << FIXNUM_BITS); - output += mpz_get_ui(x->big.big_num); - } - return output; - } - } - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), - ECL_LONG_LONG_BITS))), - x); + if (!ecl_minusp(x)) { + if (ECL_FIXNUMP(x)) { + return (ecl_ulong_long_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_ulong_p(x->big.big_num)) { + return (ecl_ulong_long_t)mpz_get_ui(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + int i = ECL_LONG_LONG_BITS - FIXNUM_BITS; + mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_ulong_long_t output; + output = mpz_get_ui(copy->big.big_num); + for (i -= FIXNUM_BITS; i; i-= FIXNUM_BITS) { + output = (output << FIXNUM_BITS); + output += mpz_get_ui(x->big.big_num); + } + return output; + } + } + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), + ECL_LONG_LONG_BITS))), + x); } ecl_long_long_t ecl_to_long_long(cl_object x) { - if (ECL_FIXNUMP(x)) { - return (ecl_long_long_t)ecl_fixnum(x); - } else if (!ECL_BIGNUMP(x)) { - (void)0; - } else if (mpz_fits_slong_p(x->big.big_num)) { - return (ecl_long_long_t)mpz_get_si(x->big.big_num); - } else { - cl_object copy = _ecl_big_register0(); - int i = ECL_LONG_LONG_BITS - FIXNUM_BITS; - mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); - if (mpz_fits_ulong_p(copy->big.big_num)) { - volatile ecl_long_long_t output; - output = mpz_get_si(copy->big.big_num); - for (i -= FIXNUM_BITS; i; i-= FIXNUM_BITS) { - output = (output << FIXNUM_BITS); - output += mpz_get_ui(x->big.big_num); - } - return output; - } - } - FEwrong_type_argument(cl_list(3,@'integer', - ecl_negate(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1)), - ecl_one_minus(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1))), - x); + if (ECL_FIXNUMP(x)) { + return (ecl_long_long_t)ecl_fixnum(x); + } else if (!ECL_BIGNUMP(x)) { + (void)0; + } else if (mpz_fits_slong_p(x->big.big_num)) { + return (ecl_long_long_t)mpz_get_si(x->big.big_num); + } else { + cl_object copy = _ecl_big_register0(); + int i = ECL_LONG_LONG_BITS - FIXNUM_BITS; + mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i); + if (mpz_fits_ulong_p(copy->big.big_num)) { + volatile ecl_long_long_t output; + output = mpz_get_si(copy->big.big_num); + for (i -= FIXNUM_BITS; i; i-= FIXNUM_BITS) { + output = (output << FIXNUM_BITS); + output += mpz_get_ui(x->big.big_num); + } + return output; + } + } + FEwrong_type_argument(cl_list(3,@'integer', + ecl_negate(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1)), + ecl_one_minus(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1))), + x); } cl_object @@ -421,30 +421,30 @@ ecl_make_long_long(ecl_long_long_t i) cl_object ecl_make_ratio(cl_object num, cl_object den) { - cl_object g, r; + cl_object g, r; - /* INV: the arguments NUM & DEN are integers */ - if (den == ecl_make_fixnum(0)) - FEdivision_by_zero(num, den); - if (num == ecl_make_fixnum(0) || den == ecl_make_fixnum(1)) - return(num); - if (ecl_minusp(den)) { - num = ecl_negate(num); - den = ecl_negate(den); - } - g = ecl_gcd(num, den); + /* INV: the arguments NUM & DEN are integers */ + if (den == ecl_make_fixnum(0)) + FEdivision_by_zero(num, den); + if (num == ecl_make_fixnum(0) || den == ecl_make_fixnum(1)) + return(num); + if (ecl_minusp(den)) { + num = ecl_negate(num); + den = ecl_negate(den); + } + g = ecl_gcd(num, den); if (g != ecl_make_fixnum(1)) { num = ecl_integer_divide(num, g); den = ecl_integer_divide(den, g); } - if (den == ecl_make_fixnum(1)) - return num; - if (den == ecl_make_fixnum(-1)) - return ecl_negate(num); - r = ecl_alloc_object(t_ratio); - r->ratio.num = num; - r->ratio.den = den; - return(r); + if (den == ecl_make_fixnum(1)) + return num; + if (den == ecl_make_fixnum(-1)) + return ecl_negate(num); + r = ecl_alloc_object(t_ratio); + r->ratio.num = num; + r->ratio.den = den; + return(r); } void @@ -452,172 +452,172 @@ ecl_deliver_fpe(int status) { cl_env_ptr env = ecl_process_env(); int bits = status & env->trap_fpe_bits; - feclearexcept(FE_ALL_EXCEPT); + feclearexcept(FE_ALL_EXCEPT); if (bits) { cl_object condition; - if (bits & FE_DIVBYZERO) - condition = @'division-by-zero'; - else if (bits & FE_INVALID) - condition = @'floating-point-invalid-operation'; - else if (bits & FE_OVERFLOW) - condition = @'floating-point-overflow'; - else if (bits & FE_UNDERFLOW) - condition = @'floating-point-underflow'; - else if (bits & FE_INEXACT) - condition = @'floating-point-inexact'; + if (bits & FE_DIVBYZERO) + condition = @'division-by-zero'; + else if (bits & FE_INVALID) + condition = @'floating-point-invalid-operation'; + else if (bits & FE_OVERFLOW) + condition = @'floating-point-overflow'; + else if (bits & FE_UNDERFLOW) + condition = @'floating-point-underflow'; + else if (bits & FE_INEXACT) + condition = @'floating-point-inexact'; else condition = @'arithmetic-error'; - cl_error(1, condition); + cl_error(1, condition); } } cl_object ecl_make_single_float(float f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (float)0.0) { + DO_DETECT_FPE(f); + if (f == (float)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) + if (signbit(f)) return cl_core.singlefloat_minus_zero; #endif return cl_core.singlefloat_zero; - } - x = ecl_alloc_object(t_singlefloat); - ecl_single_float(x) = f; - return(x); + } + x = ecl_alloc_object(t_singlefloat); + ecl_single_float(x) = f; + return(x); } cl_object ecl_make_double_float(double f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (double)0.0) { + DO_DETECT_FPE(f); + if (f == (double)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) + if (signbit(f)) return cl_core.doublefloat_minus_zero; #endif return cl_core.doublefloat_zero; - } - x = ecl_alloc_object(t_doublefloat); - ecl_double_float(x) = f; - return(x); + } + x = ecl_alloc_object(t_doublefloat); + ecl_double_float(x) = f; + return(x); } #ifdef ECL_LONG_FLOAT cl_object ecl_make_long_float(long double f) { - cl_object x; + cl_object x; - DO_DETECT_FPE(f); - if (f == (long double)0.0) { + DO_DETECT_FPE(f); + if (f == (long double)0.0) { #if defined(ECL_SIGNED_ZERO) - if (signbit(f)) + if (signbit(f)) return cl_core.longfloat_minus_zero; #endif return cl_core.longfloat_zero; - } - x = ecl_alloc_object(t_longfloat); - x->longfloat.value = f; - return x; + } + x = ecl_alloc_object(t_longfloat); + x->longfloat.value = f; + return x; } #endif cl_object ecl_make_complex(cl_object r, cl_object i) { - cl_object c; - cl_type ti; + cl_object c; + cl_type ti; AGAIN: - ti = ecl_t_of(i); - /* Both R and I are promoted to a common type */ - switch (ecl_t_of(r)) { - case t_fixnum: - case t_bignum: - case t_ratio: - switch (ti) { - case t_fixnum: - if (i == ecl_make_fixnum(0)) - return(r); - case t_bignum: - case t_ratio: - break; - case t_singlefloat: - r = ecl_make_single_float((float)ecl_to_double(r)); - break; - case t_doublefloat: - r = ecl_make_double_float(ecl_to_double(r)); - break; + ti = ecl_t_of(i); + /* Both R and I are promoted to a common type */ + switch (ecl_t_of(r)) { + case t_fixnum: + case t_bignum: + case t_ratio: + switch (ti) { + case t_fixnum: + if (i == ecl_make_fixnum(0)) + return(r); + case t_bignum: + case t_ratio: + break; + case t_singlefloat: + r = ecl_make_single_float((float)ecl_to_double(r)); + break; + case t_doublefloat: + r = ecl_make_double_float(ecl_to_double(r)); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float(ecl_to_double(r)); - break; + case t_longfloat: + r = ecl_make_long_float(ecl_to_double(r)); + break; #endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; - case t_singlefloat: - switch (ti) { - case t_fixnum: - case t_bignum: - case t_ratio: - i = ecl_make_single_float((float)ecl_to_double(i)); - break; - case t_singlefloat: - break; - case t_doublefloat: - r = ecl_make_double_float((double)(ecl_single_float(r))); - break; + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; + case t_singlefloat: + switch (ti) { + case t_fixnum: + case t_bignum: + case t_ratio: + i = ecl_make_single_float((float)ecl_to_double(i)); + break; + case t_singlefloat: + break; + case t_doublefloat: + r = ecl_make_double_float((double)(ecl_single_float(r))); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float((long double)ecl_single_float(r)); - break; + case t_longfloat: + r = ecl_make_long_float((long double)ecl_single_float(r)); + break; #endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; - case t_doublefloat: - switch (ti) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - i = ecl_make_double_float(ecl_to_double(i)); - case t_doublefloat: - break; + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; + case t_doublefloat: + switch (ti) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + i = ecl_make_double_float(ecl_to_double(i)); + case t_doublefloat: + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - r = ecl_make_long_float((long double)ecl_double_float(r)); - break; + case t_longfloat: + r = ecl_make_long_float((long double)ecl_double_float(r)); + break; #endif - default: - i = ecl_type_error(@'complex',"imaginary part", i, @'real'); - goto AGAIN; - } - break; + default: + i = ecl_type_error(@'complex',"imaginary part", i, @'real'); + goto AGAIN; + } + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - if (ti != t_longfloat) - i = ecl_make_long_float((long double)ecl_to_double(i)); - break; + case t_longfloat: + if (ti != t_longfloat) + i = ecl_make_long_float((long double)ecl_to_double(i)); + break; #endif - default: - r = ecl_type_error(@'complex',"real part", r, @'real'); - goto AGAIN; + default: + r = ecl_type_error(@'complex',"real part", r, @'real'); + goto AGAIN; - } - c = ecl_alloc_object(t_complex); - c->complex.real = r; - c->complex.imag = i; - return(c); + } + c = ecl_alloc_object(t_complex); + c->complex.real = r; + c->complex.imag = i; + return(c); } static cl_object @@ -671,7 +671,7 @@ prepare_ratio_to_float(cl_object num, cl_object den, int digits, cl_fixnum *scal } } do { - const cl_env_ptr the_env = ecl_process_env(); + const cl_env_ptr the_env = ecl_process_env(); cl_object fraction = ecl_truncate2(num, den); cl_object rem = ecl_nth_value(the_env, 1); cl_fixnum len = ecl_integer_length(fraction); @@ -747,128 +747,128 @@ ratio_to_long_double(cl_object num, cl_object den) float ecl_to_float(cl_object x) { - if (ECL_FIXNUMP(x)) return(ecl_fixnum(x)); /* Immediate fixnum */ + if (ECL_FIXNUMP(x)) return(ecl_fixnum(x)); /* Immediate fixnum */ - switch (ecl_t_of(x)) { - case t_fixnum: - return (float)ecl_fixnum(x); - case t_bignum: - return (float)ratio_to_double(x, ecl_make_fixnum(1)); - case t_ratio: + switch (ecl_t_of(x)) { + case t_fixnum: + return (float)ecl_fixnum(x); + case t_bignum: + return (float)ratio_to_double(x, ecl_make_fixnum(1)); + case t_ratio: return (float)ratio_to_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return ecl_single_float(x); - case t_doublefloat: - return (float)ecl_double_float(x); + case t_singlefloat: + return ecl_single_float(x); + case t_doublefloat: + return (float)ecl_double_float(x); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (float)ecl_long_float(x); + case t_longfloat: + return (float)ecl_long_float(x); #endif - default: + default: FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + } } double ecl_to_double(cl_object x) { - switch(ecl_t_of(x)) { - case t_fixnum: - return((double)(ecl_fixnum(x))); - case t_bignum: - return ratio_to_double(x, ecl_make_fixnum(1)); - case t_ratio: + switch(ecl_t_of(x)) { + case t_fixnum: + return((double)(ecl_fixnum(x))); + case t_bignum: + return ratio_to_double(x, ecl_make_fixnum(1)); + case t_ratio: return ratio_to_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return (double)ecl_single_float(x); - case t_doublefloat: - return(ecl_double_float(x)); + case t_singlefloat: + return (double)ecl_single_float(x); + case t_doublefloat: + return(ecl_double_float(x)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return (double)ecl_long_float(x); + case t_longfloat: + return (double)ecl_long_float(x); #endif - default: - FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + default: + FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); + } } #ifdef ECL_LONG_FLOAT long double ecl_to_long_double(cl_object x) { - switch(ecl_t_of(x)) { - case t_fixnum: - return (long double)ecl_fixnum(x); - case t_bignum: + switch(ecl_t_of(x)) { + case t_fixnum: + return (long double)ecl_fixnum(x); + case t_bignum: return ratio_to_long_double(x, ecl_make_fixnum(1)); - case t_ratio: + case t_ratio: return ratio_to_long_double(x->ratio.num, x->ratio.den); - case t_singlefloat: - return (long double)ecl_single_float(x); - case t_doublefloat: - return (long double)ecl_double_float(x); - case t_longfloat: - return ecl_long_float(x); - default: - FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); - } + case t_singlefloat: + return (long double)ecl_single_float(x); + case t_doublefloat: + return (long double)ecl_double_float(x); + case t_longfloat: + return ecl_long_float(x); + default: + FEwrong_type_nth_arg(@[coerce], 1, x, @[real]); + } } #endif cl_object cl_rational(cl_object x) { - double d; + double d; AGAIN: - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - case t_ratio: - break; - case t_singlefloat: - d = ecl_single_float(x); - goto GO_ON; - case t_doublefloat: - d = ecl_double_float(x); - GO_ON: if (d == 0) { - x = ecl_make_fixnum(0); - } else { - int e; - d = frexp(d, &e); - e -= DBL_MANT_DIG; - x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + break; + case t_singlefloat: + d = ecl_single_float(x); + goto GO_ON; + case t_doublefloat: + d = ecl_double_float(x); + GO_ON: if (d == 0) { + x = ecl_make_fixnum(0); + } else { + int e; + d = frexp(d, &e); + e -= DBL_MANT_DIG; + x = _ecl_double_to_integer(ldexp(d, DBL_MANT_DIG)); if (e != 0) { x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), ecl_make_fixnum(e)), x); } - } - break; + } + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - if (d == 0) { - x = ecl_make_fixnum(0); - } else { - int e; - d = frexpl(d, &e); - e -= LDBL_MANT_DIG; + case t_longfloat: { + long double d = ecl_long_float(x); + if (d == 0) { + x = ecl_make_fixnum(0); + } else { + int e; + d = frexpl(d, &e); + e -= LDBL_MANT_DIG; d = ldexpl(d, LDBL_MANT_DIG); - x = _ecl_long_double_to_integer(d); - if (e != 0) { - x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), + x = _ecl_long_double_to_integer(d); + if (e != 0) { + x = ecl_times(ecl_expt(ecl_make_fixnum(FLT_RADIX), ecl_make_fixnum(e)), x); - } - } - break; - } + } + } + break; + } #endif - default: - x = ecl_type_error(@'rational',"argument",x,@'number'); - goto AGAIN; - } - @(return x) + default: + x = ecl_type_error(@'rational',"argument",x,@'number'); + goto AGAIN; + } + @(return x) } #ifdef ECL_LONG_FLOAT @@ -897,23 +897,23 @@ _ecl_long_double_to_integer(long double d0) cl_object _ecl_double_to_integer(double d) { - if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum((cl_fixnum)d); - else { + if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum((cl_fixnum)d); + else { cl_object z = _ecl_big_register0(); _ecl_big_set_d(z, d); return _ecl_big_register_copy(z); - } + } } cl_object _ecl_float_to_integer(float d) { - if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) - return ecl_make_fixnum((cl_fixnum)d); - else { + if (d <= MOST_POSITIVE_FIXNUM && d >= MOST_NEGATIVE_FIXNUM) + return ecl_make_fixnum((cl_fixnum)d); + else { cl_object z = _ecl_big_register0(); _ecl_big_set_d(z, d); return _ecl_big_register_copy(z); - } + } } diff --git a/src/c/numbers/abs.d b/src/c/numbers/abs.d index aecffeaf4..86e9bae0c 100644 --- a/src/c/numbers/abs.d +++ b/src/c/numbers/abs.d @@ -49,14 +49,14 @@ ecl_abs_rational(cl_object x) static cl_object ecl_abs_single_float(cl_object x) { - float f = ecl_single_float(x); + float f = ecl_single_float(x); return (f < 0)? ecl_make_single_float(-f) : x; } static cl_object ecl_abs_double_float(cl_object x) { - double f = ecl_double_float(x); + double f = ecl_double_float(x); return (f < 0)? ecl_make_double_float(-f) : x; } @@ -64,7 +64,7 @@ ecl_abs_double_float(cl_object x) static cl_object ecl_abs_long_float(cl_object x) { - long double f = ecl_long_float(x); + long double f = ecl_long_float(x); return (f < 0)? ecl_make_long_float(-f) : x; } #endif diff --git a/src/c/numbers/atan.d b/src/c/numbers/atan.d index 304860e2b..db21868bb 100644 --- a/src/c/numbers/atan.d +++ b/src/c/numbers/atan.d @@ -27,29 +27,29 @@ ecl_atan2_double(double y, double x) { if (signbit(x)) { if (signbit(y)) { - return -ECL_PI_D + atan(-y / -x); + return -ECL_PI_D + atan(-y / -x); } else if (y == 0) { - return ECL_PI_D; + return ECL_PI_D; } else { - return ECL_PI_D - atan(y / -x); - } - } else if (x == 0) { + return ECL_PI_D - atan(y / -x); + } + } else if (x == 0) { if (signbit(y)) { - return -ECL_PI2_D; + return -ECL_PI2_D; } else if (y == 0) { return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_D; - } - } else { + } else { + return ECL_PI2_D; + } + } else { if (signbit(y)) { return -atan(-y / x); } else if (y == 0) { return (double)0; } else { return atan(y / x); - } - } + } + } } #ifdef ECL_LONG_FLOAT @@ -58,29 +58,29 @@ ecl_atan2_long_double(long double y, long double x) { if (signbit(x)) { if (signbit(y)) { - return -ECL_PI_L + atanl(-y / -x); + return -ECL_PI_L + atanl(-y / -x); } else if (y == 0) { - return ECL_PI_L; + return ECL_PI_L; } else { - return ECL_PI_L - atanl(y / -x); - } - } else if (x == 0) { + return ECL_PI_L - atanl(y / -x); + } + } else if (x == 0) { if (signbit(y)) { - return -ECL_PI2_L; + return -ECL_PI2_L; } else if (y == 0) { return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_L; - } - } else { + } else { + return ECL_PI2_L; + } + } else { if (signbit(y)) { return -atanl(-y / x); } else if (y == 0) { return (long double)0; } else { return atanl(y / x); - } - } + } + } } #endif @@ -91,33 +91,33 @@ ecl_atan2(cl_object y, cl_object x) ECL_MATHERR_CLEAR; { #ifdef ECL_LONG_FLOAT - int tx = ecl_t_of(x); - int ty = ecl_t_of(y); - if (tx < ty) - tx = ty; - if (tx == t_longfloat) { + int tx = ecl_t_of(x); + int ty = ecl_t_of(y); + if (tx < ty) + tx = ty; + if (tx == t_longfloat) { long double d = ecl_atan2_long_double(ecl_to_long_double(y), ecl_to_long_double(x)); - output = ecl_make_long_float(d); - } else { - double dx = ecl_to_double(x); - double dy = ecl_to_double(y); - double dz = ecl_atan2_double(dy, dx); - if (tx == t_doublefloat) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } - } + output = ecl_make_long_float(d); + } else { + double dx = ecl_to_double(x); + double dy = ecl_to_double(y); + double dz = ecl_atan2_double(dy, dx); + if (tx == t_doublefloat) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } + } #else - double dy = ecl_to_double(y); - double dx = ecl_to_double(x); - double dz = ecl_atan2_double(dy, dx); - if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } + double dy = ecl_to_double(y); + double dx = ecl_to_double(x); + double dz = ecl_atan2_double(dy, dx); + if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } #endif } ECL_MATHERR_TEST; @@ -127,34 +127,34 @@ ecl_atan2(cl_object y, cl_object x) cl_object ecl_atan1(cl_object y) { - if (ECL_COMPLEXP(y)) { + if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); - z = ecl_plus(ecl_log1(ecl_one_plus(z)), - ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); - z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + cl_object z = ecl_times(cl_core.imag_unit, y); + z = ecl_plus(ecl_log1(ecl_one_plus(z)), + ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); + z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), + cl_core.imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); - z = ecl_one_plus(z); - z1 = ecl_times(y, y); - z1 = ecl_one_plus(z1); - z1 = ecl_sqrt(z1); - z = ecl_divide(z, z1); - z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + cl_object z1, z = ecl_times(cl_core.imag_unit, y); + z = ecl_one_plus(z); + z1 = ecl_times(y, y); + z1 = ecl_one_plus(z1); + z1 = ecl_sqrt(z1); + z = ecl_divide(z, z1); + z = ecl_log1(z); + z = ecl_times(cl_core.minus_imag_unit, z); #endif /* ANSI */ - return z; - } else { - return ecl_atan2(y, ecl_make_fixnum(1)); - } + return z; + } else { + return ecl_atan2(y, ecl_make_fixnum(1)); + } } @(defun atan (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_atan() & ecl_atan2() */ - /* FIXME ecl_atan() and ecl_atan2() produce generic errors - without recovery and function information. */ - if (y == OBJNULL) - @(return ecl_atan1(x)) - @(return ecl_atan2(x, y)) +@ /* INV: type check in ecl_atan() & ecl_atan2() */ + /* FIXME ecl_atan() and ecl_atan2() produce generic errors + without recovery and function information. */ + if (y == OBJNULL) + @(return ecl_atan1(x)) + @(return ecl_atan2(x, y)) @) diff --git a/src/c/numbers/ceiling.d b/src/c/numbers/ceiling.d index 45e738ed0..26f91ba26 100644 --- a/src/c/numbers/ceiling.d +++ b/src/c/numbers/ceiling.d @@ -23,213 +23,213 @@ @(defun ceiling (x &optional (y OBJNULL)) @ - if (narg == 1) - return ecl_ceiling1(x); - else - return ecl_ceiling2(x, y); + if (narg == 1) + return ecl_ceiling1(x); + else + return ecl_ceiling2(x, y); @) cl_object ecl_ceiling1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: { - const cl_env_ptr the_env = ecl_process_env(); - v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } - case t_singlefloat: { - float d = ecl_single_float(x); - float y = ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: { + const cl_env_ptr the_env = ecl_process_env(); + v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } + case t_singlefloat: { + float d = ecl_single_float(x); + float y = ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); - } - @(return v0 v1) + default: + FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); + } + @(return v0 v1) } cl_object ecl_ceiling2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_type ty; + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_type ty; ty = ecl_t_of(y); - if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { - FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); - } - switch(ecl_t_of(x)) { - case t_fixnum: - switch(ty) { - case t_fixnum: { /* FIX / FIX */ - cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); - cl_fixnum q = a / b; cl_fixnum r = a % b; - if ((r^b) > 0 && r) { /* same signs and some remainder */ - v0 = ecl_make_fixnum(q+1); - v1 = ecl_make_fixnum(r-b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - case t_bignum: { /* FIX / BIG */ - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ + if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { + FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); + } + switch(ecl_t_of(x)) { + case t_fixnum: + switch(ty) { + case t_fixnum: { /* FIX / FIX */ + cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); + cl_fixnum q = a / b; cl_fixnum r = a % b; + if ((r^b) > 0 && r) { /* same signs and some remainder */ + v0 = ecl_make_fixnum(q+1); + v1 = ecl_make_fixnum(r-b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); + } + break; + } + case t_bignum: { /* FIX / BIG */ + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ ECL_WITH_TEMP_BIGNUM(bx,4); _ecl_big_set_fixnum(bx, ecl_fixnum(x)); v0 = _ecl_big_ceiling(bx, y, &v1); - break; - } - case t_ratio: /* FIX / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* FIX / SF */ - float n = ecl_single_float(y); - float p = ecl_fixnum(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* FIX / DF */ - double n = ecl_double_float(y); - double p = ecl_fixnum(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + break; + } + case t_ratio: /* FIX / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* FIX / SF */ + float n = ecl_single_float(y); + float p = ecl_fixnum(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* FIX / DF */ + double n = ecl_double_float(y); + double p = ecl_fixnum(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_bignum: - switch(ecl_t_of(y)) { - case t_fixnum: { /* BIG / FIX */ + default: + (void)0; /*Never reached */ + } + break; + case t_bignum: + switch(ecl_t_of(y)) { + case t_fixnum: { /* BIG / FIX */ ECL_WITH_TEMP_BIGNUM(by,4); _ecl_big_set_fixnum(by, ecl_fixnum(y)); v0 = _ecl_big_ceiling(x, by, &v1); - break; - } - case t_bignum: { /* BIG / BIG */ + break; + } + case t_bignum: { /* BIG / BIG */ v0 = _ecl_big_ceiling(x, y, &v1); - break; - } - case t_ratio: /* BIG / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* BIG / SF */ - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* BIG / DF */ - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + break; + } + case t_ratio: /* BIG / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* BIG / SF */ + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* BIG / DF */ + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* BIG / LF */ - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* BIG / LF */ + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_ratio: - switch(ecl_t_of(y)) { - case t_ratio: /* RAT / RAT */ - v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - default: /* RAT / ANY */ - v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - } - break; - case t_singlefloat: { /* SF / ANY */ - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* DF / ANY */ - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + default: + (void)0; /*Never reached */ + } + break; + case t_ratio: + switch(ecl_t_of(y)) { + case t_ratio: /* RAT / RAT */ + v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + default: /* RAT / ANY */ + v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + } + break; + case t_singlefloat: { /* SF / ANY */ + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* DF / ANY */ + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* LF / ANY */ - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* LF / ANY */ + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]); - } - ecl_return2(the_env, v0, v1); + } + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/cos.d b/src/c/numbers/cos.d index 0c2988e2c..7c7eea5c8 100644 --- a/src/c/numbers/cos.d +++ b/src/c/numbers/cos.d @@ -57,7 +57,7 @@ ecl_cos_long_float(cl_object x) static cl_object ecl_cos_complex(cl_object x) { - /* z = x + I y + /* z = x + I y cos(z) = cosh(I z) = cosh(-y + I x) */ cl_object dx = x->complex.real; diff --git a/src/c/numbers/divide.d b/src/c/numbers/divide.d index 9f68133cb..a06675293 100644 --- a/src/c/numbers/divide.d +++ b/src/c/numbers/divide.d @@ -18,14 +18,14 @@ @(defun / (num &rest nums) @ - /* INV: type check is in ecl_divide() */ - if (narg == 0) - FEwrong_num_arguments(@[/]); - if (narg == 1) - @(return ecl_divide(ecl_make_fixnum(1), num)) - while (--narg) - num = ecl_divide(num, ecl_va_arg(nums)); - @(return num) + /* INV: type check is in ecl_divide() */ + if (narg == 0) + FEwrong_num_arguments(@[/]); + if (narg == 1) + @(return ecl_divide(ecl_make_fixnum(1), num)) + while (--narg) + num = ecl_divide(num, ecl_va_arg(nums)); + @(return num) @) #ifdef MATH_DISPATCH2_BEGIN @@ -180,146 +180,146 @@ MATH_DISPATCH2_END; cl_object ecl_divide(cl_object x, cl_object y) { - cl_object z, z1, z2; + cl_object z, z1, z2; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - if (ecl_minusp(y) == TRUE) { - x = ecl_negate(x); - y = ecl_negate(y); - } - return ecl_make_ratio(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - return ecl_make_ratio(z, y->ratio.num); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + if (ecl_minusp(y) == TRUE) { + x = ecl_negate(x); + y = ecl_negate(y); + } + return ecl_make_ratio(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + return ecl_make_ratio(z, y->ratio.num); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - z = ecl_times(x->ratio.den, y); - return ecl_make_ratio(x->ratio.num, z); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + z = ecl_times(x->ratio.den, y); + return ecl_make_ratio(x->ratio.num, z); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - z1 = ecl_divide(x->complex.real, y); - z2 = ecl_divide(x->complex.imag, y); - return ecl_make_complex(z1, z2); - } else if (1) { - /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ - z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), - ecl_times(x->complex.imag, y->complex.imag)); - z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), - ecl_times(x->complex.real, y->complex.imag)); - } else { - COMPLEX: /* INV: x is real, y is complex */ - /* #C(z1 z2) = x * #C(yr -yi) */ - z1 = ecl_times(x, y->complex.real); - z2 = ecl_negate(ecl_times(x, y->complex.imag)); - } - z = ecl_plus(ecl_times(y->complex.real, y->complex.real), - ecl_times(y->complex.imag, y->complex.imag)); - z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); - return(z); - default: - FEwrong_type_nth_arg(@[/], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + z1 = ecl_divide(x->complex.real, y); + z2 = ecl_divide(x->complex.imag, y); + return ecl_make_complex(z1, z2); + } else if (1) { + /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ + z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), + ecl_times(x->complex.imag, y->complex.imag)); + z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), + ecl_times(x->complex.real, y->complex.imag)); + } else { + COMPLEX: /* INV: x is real, y is complex */ + /* #C(z1 z2) = x * #C(yr -yi) */ + z1 = ecl_times(x, y->complex.real); + z2 = ecl_negate(ecl_times(x, y->complex.imag)); + } + z = ecl_plus(ecl_times(y->complex.real, y->complex.real), + ecl_times(y->complex.imag, y->complex.imag)); + z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); + return(z); + default: + FEwrong_type_nth_arg(@[/], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/expt.d b/src/c/numbers/expt.d index 1ec395ea4..c6742c4f4 100644 --- a/src/c/numbers/expt.d +++ b/src/c/numbers/expt.d @@ -29,16 +29,16 @@ cl_fixnum ecl_fixnum_expt(cl_fixnum x, cl_fixnum y) { - cl_fixnum z = 1; - while (y > 0) - if (y%2 == 0) { - x *= x; - y /= 2; - } else { - z *= x; - --y; - } - return(z); + cl_fixnum z = 1; + while (y > 0) + if (y%2 == 0) { + x *= x; + y /= 2; + } else { + z *= x; + --y; + } + return(z); } cl_object @@ -56,13 +56,13 @@ ecl_def_ct_long_float(longfloat_one,1,static,const); static cl_object expt_zero(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; + cl_type ty, tx; + cl_object z; ty = ecl_t_of(y); tx = ecl_t_of(x); if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } + } /* INV: The most specific numeric types come first. */ switch ((ty > tx)? ty : tx) { case t_fixnum: @@ -90,45 +90,45 @@ expt_zero(cl_object x, cl_object y) cl_object ecl_expt(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; - if (ecl_unlikely(ecl_zerop(y))) { + cl_type ty, tx; + cl_object z; + if (ecl_unlikely(ecl_zerop(y))) { return expt_zero(x, y); - } + } ty = ecl_t_of(y); tx = ecl_t_of(x); if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } + } if (ecl_zerop(x)) { - z = ecl_times(x, y); - if (!ecl_plusp(ty==t_complex?y->complex.real:y)) - z = ecl_divide(ecl_make_fixnum(1), z); - } else if (ty != t_fixnum && ty != t_bignum) { + z = ecl_times(x, y); + if (!ecl_plusp(ty==t_complex?y->complex.real:y)) + z = ecl_divide(ecl_make_fixnum(1), z); + } else if (ty != t_fixnum && ty != t_bignum) { /* The following could be just z = ecl_log1(x); however, Maxima expects EXPT to have double accuracy when the first argument is integer and the second is double-float */ - z = ecl_log1(ecl_times(x, expt_zero(x, y))); - z = ecl_times(z, y); - z = ecl_exp(z); - } else if (ecl_minusp(y)) { - z = ecl_negate(y); - z = ecl_expt(x, z); - z = ecl_divide(ecl_make_fixnum(1), z); - } else { + z = ecl_log1(ecl_times(x, expt_zero(x, y))); + z = ecl_times(z, y); + z = ecl_exp(z); + } else if (ecl_minusp(y)) { + z = ecl_negate(y); + z = ecl_expt(x, z); + z = ecl_divide(ecl_make_fixnum(1), z); + } else { ECL_MATHERR_CLEAR; - z = ecl_make_fixnum(1); - do { - /* INV: ecl_integer_divide outputs an integer */ - if (!ecl_evenp(y)) - z = ecl_times(z, x); - y = ecl_integer_divide(y, ecl_make_fixnum(2)); - if (ecl_zerop(y)) break; - x = ecl_times(x, x); - } while (1); + z = ecl_make_fixnum(1); + do { + /* INV: ecl_integer_divide outputs an integer */ + if (!ecl_evenp(y)) + z = ecl_times(z, x); + y = ecl_integer_divide(y, ecl_make_fixnum(2)); + if (ecl_zerop(y)) break; + x = ecl_times(x, x); + } while (1); ECL_MATHERR_TEST; - } - return z; + } + return z; } diff --git a/src/c/numbers/float_fix_compare.d b/src/c/numbers/float_fix_compare.d index 0cd643002..29d62e1d0 100644 --- a/src/c/numbers/float_fix_compare.d +++ b/src/c/numbers/float_fix_compare.d @@ -26,50 +26,50 @@ static int double_fix_compare(cl_fixnum n, double d) { - if ((double)n < d) { - return -1; - } else if ((double)n > d) { - return +1; - } else if (sizeof(double) > sizeof(cl_fixnum)) { - return 0; - } else { - /* When we reach here, the double type has no - * significant decimal part. However, as explained - * above, the double type is too small and integers - * may coerce to the same double number giving a false - * positive. Hence we perform the comparison in - * integer space. */ - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((double)n < d) { + return -1; + } else if ((double)n > d) { + return +1; + } else if (sizeof(double) > sizeof(cl_fixnum)) { + return 0; + } else { + /* When we reach here, the double type has no + * significant decimal part. However, as explained + * above, the double type is too small and integers + * may coerce to the same double number giving a false + * positive. Hence we perform the comparison in + * integer space. */ + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #ifdef ECL_LONG_FLOAT static int long_double_fix_compare(cl_fixnum n, long double d) { - if ((long double)n < d) { - return -1; - } else if ((long double)n > d) { - return +1; - } else if (sizeof(long double) > sizeof(cl_fixnum)) { - return 0; - } else { - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((long double)n < d) { + return -1; + } else if ((long double)n > d) { + return +1; + } else if (sizeof(long double) > sizeof(cl_fixnum)) { + return 0; + } else { + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #endif diff --git a/src/c/numbers/floor.d b/src/c/numbers/floor.d index 31729f6bf..27658c7cc 100644 --- a/src/c/numbers/floor.d +++ b/src/c/numbers/floor.d @@ -24,232 +24,232 @@ @(defun floor (x &optional (y OBJNULL)) @ - if (narg == 1) - return ecl_floor1(x); - else - return ecl_floor2(x, y); + if (narg == 1) + return ecl_floor1(x); + else + return ecl_floor2(x, y); @) cl_object ecl_floor1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_floor2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float y = floorf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = floor(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_floor2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float y = floorf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = floor(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = floorl(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = floorl(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[floor],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_floor2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; MATH_DISPATCH2_BEGIN(x,y) { - CASE_FIXNUM_FIXNUM { - cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); - cl_fixnum q = a / b, r = a % b; - if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ - v0 = ecl_make_fixnum(q-1); - v1 = ecl_make_fixnum(r+b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - CASE_FIXNUM_BIGNUM { - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ - ECL_WITH_TEMP_BIGNUM(bx,4); - _ecl_big_set_fixnum(bx, ecl_fixnum(x)); - v0 = _ecl_big_floor(bx, y, &v1); - break; - } - CASE_FIXNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_FIXNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = ecl_fixnum(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_FIXNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = ecl_fixnum(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; - } + CASE_FIXNUM_FIXNUM { + cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); + cl_fixnum q = a / b, r = a % b; + if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ + v0 = ecl_make_fixnum(q-1); + v1 = ecl_make_fixnum(r+b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); + } + break; + } + CASE_FIXNUM_BIGNUM { + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ + ECL_WITH_TEMP_BIGNUM(bx,4); + _ecl_big_set_fixnum(bx, ecl_fixnum(x)); + v0 = _ecl_big_floor(bx, y, &v1); + break; + } + CASE_FIXNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_FIXNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = ecl_fixnum(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_FIXNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = ecl_fixnum(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } + CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } #endif - CASE_BIGNUM_FIXNUM { - ECL_WITH_TEMP_BIGNUM(by,4); - _ecl_big_set_fixnum(by, ecl_fixnum(y)); - v0 = _ecl_big_floor(x, by, &v1); - break; - } - CASE_BIGNUM_BIGNUM { - v0 = _ecl_big_floor(x, y, &v1); - break; - } - CASE_BIGNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_BIGNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_BIGNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; - } + CASE_BIGNUM_FIXNUM { + ECL_WITH_TEMP_BIGNUM(by,4); + _ecl_big_set_fixnum(by, ecl_fixnum(y)); + v0 = _ecl_big_floor(x, by, &v1); + break; + } + CASE_BIGNUM_BIGNUM { + v0 = _ecl_big_floor(x, y, &v1); + break; + } + CASE_BIGNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_BIGNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_BIGNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_BIGNUM_LONG_FLOAT { - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } + CASE_BIGNUM_LONG_FLOAT { + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } #endif - CASE_RATIO_RATIO { - v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM; - CASE_RATIO_SINGLE_FLOAT; + CASE_RATIO_RATIO { + v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM; + CASE_RATIO_SINGLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_RATIO_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT; #endif - CASE_RATIO_DOUBLE_FLOAT { - v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } + CASE_RATIO_DOUBLE_FLOAT { + v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } - CASE_SINGLE_FLOAT_FIXNUM; - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO; - CASE_SINGLE_FLOAT_DOUBLE_FLOAT; -#ifdef ECL_LONG_FLOAT - CASE_SINGLE_FLOAT_LONG_FLOAT; + CASE_SINGLE_FLOAT_FIXNUM; + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO; + CASE_SINGLE_FLOAT_DOUBLE_FLOAT; +#ifdef ECL_LONG_FLOAT + CASE_SINGLE_FLOAT_LONG_FLOAT; #endif - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - /* We cannot factor these two multiplications because - * if we have signed zeros (1 - 1) * (-1) = -0 while - * 1*(-1) - 1*(-1) = +0 */ - v1 = ecl_make_single_float(p*n - q*n); - break; - } - CASE_DOUBLE_FLOAT_FIXNUM; - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO; - CASE_DOUBLE_FLOAT_SINGLE_FLOAT; -#ifdef ECL_LONG_FLOAT - CASE_DOUBLE_FLOAT_LONG_FLOAT; + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + /* We cannot factor these two multiplications because + * if we have signed zeros (1 - 1) * (-1) = -0 while + * 1*(-1) - 1*(-1) = +0 */ + v1 = ecl_make_single_float(p*n - q*n); + break; + } + CASE_DOUBLE_FLOAT_FIXNUM; + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO; + CASE_DOUBLE_FLOAT_SINGLE_FLOAT; +#ifdef ECL_LONG_FLOAT + CASE_DOUBLE_FLOAT_LONG_FLOAT; #endif - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_LONG_FLOAT_FIXNUM; - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO; - CASE_LONG_FLOAT_SINGLE_FLOAT; - CASE_LONG_FLOAT_DOUBLE_FLOAT; - CASE_LONG_FLOAT_LONG_FLOAT { - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + CASE_LONG_FLOAT_FIXNUM; + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO; + CASE_LONG_FLOAT_SINGLE_FLOAT; + CASE_LONG_FLOAT_DOUBLE_FLOAT; + CASE_LONG_FLOAT_LONG_FLOAT { + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: DISPATCH2_ERROR: { - if (!ecl_realp(x)) - FEwrong_type_nth_arg(@[floor], 1, x, @[real]); - else - FEwrong_type_nth_arg(@[floor], 2, y, @[real]); - } + default: DISPATCH2_ERROR: { + if (!ecl_realp(x)) + FEwrong_type_nth_arg(@[floor], 1, x, @[real]); + else + FEwrong_type_nth_arg(@[floor], 2, y, @[real]); + } } MATH_DISPATCH2_END; - ecl_return2(the_env, v0, v1); + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/log.d b/src/c/numbers/log.d index a46c302f7..9923b3a73 100644 --- a/src/c/numbers/log.d +++ b/src/c/numbers/log.d @@ -25,29 +25,29 @@ static cl_object ecl_log1_complex_inner(cl_object r, cl_object i) { - cl_object a = ecl_abs(r); - cl_object p = ecl_abs(i); - int rel = ecl_number_compare(a, p); - if (rel > 0) { - cl_object aux = p; - p = a; a = aux; - } else if (rel == 0) { - /* if a == p, - * log(sqrt(a^2+p^2)) = log(2a^2)/2 - */ - a = ecl_times(a, a); - a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); - goto OUTPUT; - } - /* For the real part of the output we use the formula - * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) - * = log(p) + log(1 + (a/p)^2)/2; */ - a = ecl_divide(a, p); - a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), - ecl_log1(p)); + cl_object a = ecl_abs(r); + cl_object p = ecl_abs(i); + int rel = ecl_number_compare(a, p); + if (rel > 0) { + cl_object aux = p; + p = a; a = aux; + } else if (rel == 0) { + /* if a == p, + * log(sqrt(a^2+p^2)) = log(2a^2)/2 + */ + a = ecl_times(a, a); + a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); + goto OUTPUT; + } + /* For the real part of the output we use the formula + * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) + * = log(p) + log(1 + (a/p)^2)/2; */ + a = ecl_divide(a, p); + a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), + ecl_log1(p)); OUTPUT: - p = ecl_atan2(i, r); - return ecl_make_complex(a, p); + p = ecl_atan2(i, r); + return ecl_make_complex(a, p); } static cl_object @@ -114,14 +114,14 @@ MATH_DEF_DISPATCH1(log1, @[log], @[number], cl_object ecl_log2(cl_object x, cl_object y) { - return ecl_divide(ecl_log1(y), ecl_log1(x)); + return ecl_divide(ecl_log1(y), ecl_log1(x)); } @(defun log (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_log1() and ecl_log2() */ - if (y == OBJNULL) - @(return ecl_log1(x)) - @(return ecl_log2(y, x)) +@ /* INV: type check in ecl_log1() and ecl_log2() */ + if (y == OBJNULL) + @(return ecl_log1(x)) + @(return ecl_log2(y, x)) @) @@ -129,12 +129,12 @@ ecl_log2(cl_object x, cl_object y) double log1p(double x) { - double u = 1.0 + x; - if (u == 1) { - return 0.0; - } else { - return (log(u) * x)/(u - 1.0); - } + double u = 1.0 + x; + if (u == 1) { + return 0.0; + } else { + return (log(u) * x)/(u - 1.0); + } } #endif @@ -142,12 +142,12 @@ log1p(double x) float log1pf(float x) { - float u = (float)1 + x; - if (u == 1) { - return (float)0; - } else { - return (logf(u) * x)/(u - (float)1); - } + float u = (float)1 + x; + if (u == 1) { + return (float)0; + } else { + return (logf(u) * x)/(u - (float)1); + } } #endif @@ -155,19 +155,19 @@ log1pf(float x) long double log1pl(long double x) { - long double u = (long double)1 + x; - if (u == 1) { - return (long double)1; - } else { - return (logl(u) * x)/(u - (long double)1); - } + long double u = (long double)1 + x; + if (u == 1) { + return (long double)1; + } else { + return (logl(u) * x)/(u - (long double)1); + } } #endif cl_object si_log1p(cl_object x) { - @(return ecl_log1p(x)); + @(return ecl_log1p(x)); } static cl_object diff --git a/src/c/numbers/minmax.d b/src/c/numbers/minmax.d index ad178fd5e..5df2ed1a4 100644 --- a/src/c/numbers/minmax.d +++ b/src/c/numbers/minmax.d @@ -19,28 +19,28 @@ @(defun max (max &rest nums) @ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(max); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(max, numi) < 0) - max = numi; - } while (--narg); - @(return max) + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(max); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(max, numi) < 0) + max = numi; + } while (--narg); + @(return max) @) @(defun min (min &rest nums) @ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(min); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(min, numi) > 0) - min = numi; - } while (--narg); - @(return min) + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(min); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(min, numi) > 0) + min = numi; + } while (--narg); + @(return min) @) diff --git a/src/c/numbers/minus.d b/src/c/numbers/minus.d index 96d161d9f..3941c5013 100644 --- a/src/c/numbers/minus.d +++ b/src/c/numbers/minus.d @@ -17,14 +17,14 @@ #include @(defun - (num &rest nums) - cl_object diff; + cl_object diff; @ - /* INV: argument type check in number_{negate,minus}() */ - if (narg == 1) - @(return ecl_negate(num)) - for (diff = num; --narg; ) - diff = ecl_minus(diff, ecl_va_arg(nums)); - @(return diff) + /* INV: argument type check in number_{negate,minus}() */ + if (narg == 1) + @(return ecl_negate(num)) + for (diff = num; --narg; ) + diff = ecl_minus(diff, ecl_va_arg(nums)); + @(return diff) @) #ifdef MATH_DISPATCH2_BEGIN @@ -164,8 +164,8 @@ MATH_DISPATCH2_BEGIN(x,y) } CASE_COMPLEX_COMPLEX { cl_object z = ecl_minus(x->complex.real, y->complex.real); - cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); + cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); } CASE_UNKNOWN(@[-],x,y,@[number]); } @@ -177,157 +177,157 @@ MATH_DISPATCH2_END; cl_object ecl_minus(cl_object x, cl_object y) { - cl_fixnum i, j, k; - cl_object z, z1; + cl_fixnum i, j, k; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch(ecl_t_of(y)) { - case t_fixnum: + switch (ecl_t_of(x)) { + case t_fixnum: + switch(ecl_t_of(y)) { + case t_fixnum: return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); - case t_bignum: + case t_bignum: return _ecl_fix_minus_big(ecl_fixnum(x), y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: return _ecl_big_plus_fix(x, -ecl_fixnum(y)); - case t_bignum: + case t_bignum: return _ecl_big_minus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_minus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_minus(z, z1); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_minus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_minus(z, z1); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) - fix(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) - fix(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #endif - COMPLEX: - return ecl_make_complex(ecl_minus(x, y->complex.real), + COMPLEX: + return ecl_make_complex(ecl_minus(x, y->complex.real), ecl_negate(y->complex.imag)); - case t_complex: - if (ecl_t_of(y) != t_complex) { - z = ecl_minus(x->complex.real, y); - z1 = x->complex.imag; - } else { - z = ecl_minus(x->complex.real, y->complex.real); - z1 = ecl_minus(x->complex.imag, y->complex.imag); - } - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[-], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + z = ecl_minus(x->complex.real, y); + z1 = x->complex.imag; + } else { + z = ecl_minus(x->complex.real, y->complex.real); + z1 = ecl_minus(x->complex.imag, y->complex.imag); + } + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[-], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/minusp.d b/src/c/numbers/minusp.d index b42538b20..16953a8c6 100644 --- a/src/c/numbers/minusp.d +++ b/src/c/numbers/minusp.d @@ -20,8 +20,8 @@ cl_object cl_minusp(cl_object x) -{ /* INV: ecl_minusp() checks type */ - @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_minusp() checks type */ + @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)) } static int diff --git a/src/c/numbers/number_compare.d b/src/c/numbers/number_compare.d index 71d3bd510..a1aabba23 100644 --- a/src/c/numbers/number_compare.d +++ b/src/c/numbers/number_compare.d @@ -20,179 +20,179 @@ #include "numbers/float_fix_compare.d" /* - The value of ecl_number_compare(x, y) is + The value of ecl_number_compare(x, y) is - -1 if x < y - 0 if x = y - 1 if x > y. + -1 if x < y + 0 if x = y + 1 if x > y. - If x or y is not real, it fails. + If x or y is not real, it fails. */ int ecl_number_compare(cl_object x, cl_object y) { - cl_fixnum ix, iy; - double dx, dy; + cl_fixnum ix, iy; + double dx, dy; #ifdef ECL_LONG_FLOAT - long double ldx, ldy; + long double ldx, ldy; #endif - cl_type ty; + cl_type ty; BEGIN: - ty = ecl_t_of(y); - switch (ecl_t_of(x)) { - case t_fixnum: - ix = ecl_fixnum(x); - switch (ty) { - case t_fixnum: - iy = ecl_fixnum(y); - if (ix < iy) - return(-1); - else return(ix != iy); - case t_bignum: - /* INV: (= x y) can't be zero since fixnum != bignum */ - return _ecl_big_sign(y) < 0? 1 : -1; - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - return double_fix_compare(ix, ecl_single_float(y)); - case t_doublefloat: - return double_fix_compare(ix, ecl_double_float(y)); + ty = ecl_t_of(y); + switch (ecl_t_of(x)) { + case t_fixnum: + ix = ecl_fixnum(x); + switch (ty) { + case t_fixnum: + iy = ecl_fixnum(y); + if (ix < iy) + return(-1); + else return(ix != iy); + case t_bignum: + /* INV: (= x y) can't be zero since fixnum != bignum */ + return _ecl_big_sign(y) < 0? 1 : -1; + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + return double_fix_compare(ix, ecl_single_float(y)); + case t_doublefloat: + return double_fix_compare(ix, ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ix, ecl_long_float(y)); + case t_longfloat: + return long_double_fix_compare(ix, ecl_long_float(y)); #endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_bignum: - switch (ty) { - case t_fixnum: - return _ecl_big_sign(x) < 0 ? -1 : 1; - case t_bignum: - return(_ecl_big_compare(x, y)); - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - case t_doublefloat: + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_bignum: + switch (ty) { + case t_fixnum: + return _ecl_big_sign(x) < 0 ? -1 : 1; + case t_bignum: + return(_ecl_big_compare(x, y)); + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_ratio: - switch (ty) { - case t_fixnum: - case t_bignum: - y = ecl_times(y, x->ratio.den); - x = x->ratio.num; - return(ecl_number_compare(x, y)); - case t_ratio: - return(ecl_number_compare(ecl_times(x->ratio.num, - y->ratio.den), - ecl_times(y->ratio.num, - x->ratio.den))); - case t_singlefloat: - case t_doublefloat: + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_ratio: + switch (ty) { + case t_fixnum: + case t_bignum: + y = ecl_times(y, x->ratio.den); + x = x->ratio.num; + return(ecl_number_compare(x, y)); + case t_ratio: + return(ecl_number_compare(ecl_times(x->ratio.num, + y->ratio.den), + ecl_times(y->ratio.num, + x->ratio.den))); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_singlefloat: - dx = (double)(ecl_single_float(x)); - goto DOUBLEFLOAT0; - case t_doublefloat: - dx = ecl_double_float(x); - DOUBLEFLOAT0: - switch (ty) { - case t_fixnum: - return -double_fix_compare(ecl_fixnum(y), dx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - dy = (double)(ecl_single_float(y)); - break; - case t_doublefloat: - dy = ecl_double_float(y); - break; + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_singlefloat: + dx = (double)(ecl_single_float(x)); + goto DOUBLEFLOAT0; + case t_doublefloat: + dx = ecl_double_float(x); + DOUBLEFLOAT0: + switch (ty) { + case t_fixnum: + return -double_fix_compare(ecl_fixnum(y), dx); + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + dy = (double)(ecl_single_float(y)); + break; + case t_doublefloat: + dy = ecl_double_float(y); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = dx; - ldy = ecl_long_float(y); - goto LONGFLOAT; + case t_longfloat: + ldx = dx; + ldy = ecl_long_float(y); + goto LONGFLOAT; #endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - DOUBLEFLOAT: - if (dx == dy) - return(0); - else if (dx < dy) - return(-1); - else - return(1); + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + DOUBLEFLOAT: + if (dx == dy) + return(0); + else if (dx < dy) + return(-1); + else + return(1); #ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = ecl_long_float(x); - switch (ty) { - case t_fixnum: - return -long_double_fix_compare(ecl_fixnum(y), ldx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - ldy = ecl_single_float(y); - break; - case t_doublefloat: - ldy = ecl_double_float(y); - break; - case t_longfloat: - ldy = ecl_long_float(y); - break; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - LONGFLOAT: - if (ldx == ldy) - return 0; - else if (ldx < ldy) - return -1; - else - return 1; - break; + case t_longfloat: + ldx = ecl_long_float(x); + switch (ty) { + case t_fixnum: + return -long_double_fix_compare(ecl_fixnum(y), ldx); + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + ldy = ecl_single_float(y); + break; + case t_doublefloat: + ldy = ecl_double_float(y); + break; + case t_longfloat: + ldy = ecl_long_float(y); + break; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + LONGFLOAT: + if (ldx == ldy) + return 0; + else if (ldx < ldy) + return -1; + else + return 1; + break; #endif - default: - FEwrong_type_nth_arg(@[<], 1, x, @[real]); - } + default: + FEwrong_type_nth_arg(@[<], 1, x, @[real]); + } } static cl_object monotonic(int s, int t, int narg, ecl_va_list nums) { - cl_object c, d; + cl_object c, d; - if (narg == 0) - FEwrong_num_arguments_anonym(); - /* INV: type check occurs in ecl_number_compare() */ - for (c = ecl_va_arg(nums); --narg; c = d) { - d = ecl_va_arg(nums); - if (s*ecl_number_compare(d, c) < t) - return1(ECL_NIL); - } - return1(ECL_T); + if (narg == 0) + FEwrong_num_arguments_anonym(); + /* INV: type check occurs in ecl_number_compare() */ + for (c = ecl_va_arg(nums); --narg; c = d) { + d = ecl_va_arg(nums); + if (s*ecl_number_compare(d, c) < t) + return1(ECL_NIL); + } + return1(ECL_T); } #define MONOTONIC(i, j) (cl_narg narg, ...) \ diff --git a/src/c/numbers/number_equalp.d b/src/c/numbers/number_equalp.d index 25fa6300c..2310a3e75 100644 --- a/src/c/numbers/number_equalp.d +++ b/src/c/numbers/number_equalp.d @@ -20,174 +20,174 @@ #include "numbers/float_fix_compare.d" @(defun = (num &rest nums) - int i; + int i; @ - /* ANSI: Need not signal error for 1 argument */ - /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ - for (i = 1; i < narg; i++) - if (!ecl_number_equalp(num, ecl_va_arg(nums))) - @(return ECL_NIL) - @(return ECL_T) + /* ANSI: Need not signal error for 1 argument */ + /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ + for (i = 1; i < narg; i++) + if (!ecl_number_equalp(num, ecl_va_arg(nums))) + @(return ECL_NIL) + @(return ECL_T) @) /* Returns 1 if both numbers compare to equal */ int ecl_number_equalp(cl_object x, cl_object y) { - double dx; - /* INV: (= fixnum bignum) => 0 */ - /* INV: (= fixnum ratio) => 0 */ - /* INV: (= bignum ratio) => 0 */ + double dx; + /* INV: (= fixnum bignum) => 0 */ + /* INV: (= fixnum ratio) => 0 */ + /* INV: (= bignum ratio) => 0 */ BEGIN: - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return x == y; - case t_bignum: - case t_ratio: - return 0; - case t_singlefloat: - return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; - case t_doublefloat: - return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return x == y; + case t_bignum: + case t_ratio: + return 0; + case t_singlefloat: + return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; + case t_doublefloat: + return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; + case t_longfloat: + return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; #endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return 0; - case t_bignum: - return _ecl_big_compare(x, y)==0; - case t_ratio: - return 0; - case t_singlefloat: - case t_doublefloat: + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return 0; + case t_bignum: + return _ecl_big_compare(x, y)==0; + case t_ratio: + return 0; + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - return 0; - case t_ratio: - return (ecl_number_equalp(x->ratio.num, y->ratio.num) && - ecl_number_equalp(x->ratio.den, y->ratio.den)); - case t_singlefloat: - case t_doublefloat: + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + return 0; + case t_ratio: + return (ecl_number_equalp(x->ratio.num, y->ratio.num) && + ecl_number_equalp(x->ratio.den, y->ratio.den)); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_singlefloat: - dx = ecl_single_float(x); - goto FLOAT; - case t_doublefloat: - dx = ecl_double_float(x); - FLOAT: - switch (ecl_t_of(y)) { - case t_fixnum: - return double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_singlefloat: + dx = ecl_single_float(x); + goto FLOAT; + case t_doublefloat: + dx = ecl_double_float(x); + FLOAT: + switch (ecl_t_of(y)) { + case t_fixnum: + return double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return dx == ecl_long_float(y); + case t_longfloat: + return dx == ecl_long_float(y); #endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double dx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return long_double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); - case t_longfloat: - return dx == ecl_long_float(y); - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - } + case t_longfloat: { + long double dx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return long_double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); + case t_longfloat: + return dx == ecl_long_float(y); + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + } #endif - Y_COMPLEX: - if (!ecl_zerop(y->complex.imag)) - return 0; - return ecl_number_equalp(x, y->complex.real); - case t_complex: + Y_COMPLEX: + if (!ecl_zerop(y->complex.imag)) + return 0; + return ecl_number_equalp(x, y->complex.real); + case t_complex: switch (ecl_t_of(y)) { case t_complex: - return (ecl_number_equalp(x->complex.real, y->complex.real) && - ecl_number_equalp(x->complex.imag, y->complex.imag)); + return (ecl_number_equalp(x->complex.real, y->complex.real) && + ecl_number_equalp(x->complex.imag, y->complex.imag)); case t_fixnum: case t_bignum: case t_ratio: case t_singlefloat: case t_doublefloat: #ifdef ECL_LONG_FLOAT case t_longfloat: #endif - if (ecl_zerop(x->complex.imag)) - return ecl_number_equalp(x->complex.real, y) != 0; - else - return 0; + if (ecl_zerop(x->complex.imag)) + return ecl_number_equalp(x->complex.real, y) != 0; + else + return 0; default: FEwrong_type_nth_arg(@[=], 2, y, @[number]); } - default: + default: FEwrong_type_nth_arg(@[=], 1, x, @[number]); - } + } } @(defun /= (&rest nums &aux numi) - int i, j; + int i, j; @ - if (narg == 0) - FEwrong_num_arguments_anonym(); - numi = ecl_va_arg(nums); - for (i = 2; i<=narg; i++) { - ecl_va_list numb; - ecl_va_start(numb, narg, narg, 0); - numi = ecl_va_arg(nums); - for (j = 1; j @(defun + (&rest nums) - cl_object sum = ecl_make_fixnum(0); + cl_object sum = ecl_make_fixnum(0); @ - /* INV: type check is in ecl_plus() */ - while (narg--) - sum = ecl_plus(sum, ecl_va_arg(nums)); - @(return sum) + /* INV: type check is in ecl_plus() */ + while (narg--) + sum = ecl_plus(sum, ecl_va_arg(nums)); + @(return sum) @) #ifdef MATH_DISPATCH2_BEGIN @@ -162,8 +162,8 @@ MATH_DISPATCH2_BEGIN(x,y) } CASE_COMPLEX_COMPLEX { cl_object z = ecl_plus(x->complex.real, y->complex.real); - cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); + cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); } CASE_UNKNOWN(@[+],x,y,@[number]); } @@ -175,155 +175,155 @@ MATH_DISPATCH2_END; cl_object ecl_plus(cl_object x, cl_object y) { - cl_fixnum i, j; - cl_object z, z1; + cl_fixnum i, j; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); - case t_bignum: + case t_bignum: return _ecl_big_plus_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); #endif - case t_complex: - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_plus(x, y->complex.real), - y->complex.imag); - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: + case t_complex: + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_plus(x, y->complex.real), + y->complex.imag); + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: return _ecl_big_plus_fix(x, ecl_fixnum(y)); - case t_bignum: + case t_bignum: return _ecl_big_plus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_plus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z1 = ecl_times(x->ratio.num,y->ratio.den); - z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_plus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_plus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z1 = ecl_times(x->ratio.num,y->ratio.den); + z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_plus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z = ecl_plus(x->complex.real, y->complex.real); - z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[+], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z = ecl_plus(x->complex.real, y->complex.real); + z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[+], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/plusp.d b/src/c/numbers/plusp.d index 346bdb7b2..74a988221 100644 --- a/src/c/numbers/plusp.d +++ b/src/c/numbers/plusp.d @@ -20,8 +20,8 @@ cl_object cl_plusp(cl_object x) -{ /* INV: ecl_plusp() checks type */ - @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_plusp() checks type */ + @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)) } static int diff --git a/src/c/numbers/round.d b/src/c/numbers/round.d index 0a90138e4..c41338415 100644 --- a/src/c/numbers/round.d +++ b/src/c/numbers/round.d @@ -25,141 +25,141 @@ @(defun round (x &optional (y OBJNULL)) @ - if (narg == 1) - return ecl_round1(x); - else - return ecl_round2(x, y); + if (narg == 1) + return ecl_round1(x); + else + return ecl_round2(x, y); @) static cl_object number_remainder(cl_object x, cl_object y, cl_object q) { - cl_object z; + cl_object z; - z = ecl_times(q, y); - z = ecl_minus(x, z); - return(z); + z = ecl_times(q, y); + z = ecl_minus(x, z); + return(z); } static double round_double(double d) { - if (d >= 0) { - double q = floor(d += 0.5); - if (q == d) { - int i = (int)fmod(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_double(-d); - } + if (d >= 0) { + double q = floor(d += 0.5); + if (q == d) { + int i = (int)fmod(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_double(-d); + } } #ifdef ECL_LONG_FLOAT static long double round_long_double(long double d) { - if (d >= 0) { - long double q = floorl(d += 0.5); - if (q == d) { - int i = (int)fmodl(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_long_double(-d); - } + if (d >= 0) { + long double q = floorl(d += 0.5); + if (q == d) { + int i = (int)fmodl(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_long_double(-d); + } } #endif static cl_object ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object q) { - cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); - cl_object r = ecl_minus(q, q1); - if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_minus(q1); - } - } else { - int c = ecl_number_compare(r, cl_core.plus_half); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_plus(q1); - } - } - r = number_remainder(x, y, q1); - ecl_return2(the_env, q1, r); + cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); + cl_object r = ecl_minus(q, q1); + if (ecl_minusp(r)) { + int c = ecl_number_compare(cl_core.minus_half, r); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_minus(q1); + } + } else { + int c = ecl_number_compare(r, cl_core.plus_half); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_plus(q1); + } + } + r = number_remainder(x, y, q1); + ecl_return2(the_env, q1, r); } cl_object ecl_round1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float q = round_double(d); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(d - q); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double q = round_double(d); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(d - q); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float q = round_double(d); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(d - q); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double q = round_double(d); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(d - q); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double q = round_long_double(d); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(d - q); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double q = round_long_double(d); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(d - q); + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[round],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_round2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_object q; + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_object q; - q = ecl_divide(x, y); - switch (ecl_t_of(q)) { - case t_fixnum: - case t_bignum: - v0 = q; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - return ecl_round2_integer(the_env, x, y, q); - default: - v0 = q = ecl_round1(q); - v1 = number_remainder(x, y, q); - } - ecl_return2(the_env, v0, v1); + q = ecl_divide(x, y); + switch (ecl_t_of(q)) { + case t_fixnum: + case t_bignum: + v0 = q; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + return ecl_round2_integer(the_env, x, y, q); + default: + v0 = q = ecl_round1(q); + v1 = number_remainder(x, y, q); + } + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/sin.d b/src/c/numbers/sin.d index 09102c342..7634c50b2 100644 --- a/src/c/numbers/sin.d +++ b/src/c/numbers/sin.d @@ -66,7 +66,7 @@ ecl_sin_complex(cl_object x) cl_object dy = x->complex.imag; cl_object a = ecl_times(ecl_sin(dx), ecl_cosh(dy)); cl_object b = ecl_times(ecl_cos(dx), ecl_sinh(dy)); - return ecl_make_complex(a, b); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(sin, @[sin], @[number], diff --git a/src/c/numbers/tanh.d b/src/c/numbers/tanh.d index cb952311a..e390a7fff 100644 --- a/src/c/numbers/tanh.d +++ b/src/c/numbers/tanh.d @@ -58,8 +58,8 @@ static cl_object ecl_tanh_complex(cl_object x) { cl_object a = ecl_sinh(x); - cl_object b = ecl_cosh(x); - return ecl_divide(a, b); + cl_object b = ecl_cosh(x); + return ecl_divide(a, b); } MATH_DEF_DISPATCH1(tanh, @[tanh], @[number], diff --git a/src/c/numbers/times.d b/src/c/numbers/times.d index 777f37ac4..7c97347fa 100644 --- a/src/c/numbers/times.d +++ b/src/c/numbers/times.d @@ -17,12 +17,12 @@ #include @(defun * (&rest nums) - cl_object prod = ecl_make_fixnum(1); + cl_object prod = ecl_make_fixnum(1); @ - /* INV: type check in ecl_times() */ - while (narg--) - prod = ecl_times(prod, ecl_va_arg(nums)); - @(return prod) + /* INV: type check in ecl_times() */ + while (narg--) + prod = ecl_times(prod, ecl_va_arg(nums)); + @(return prod) @) #ifdef MATH_DISPATCH2_BEGIN @@ -159,11 +159,11 @@ MATH_DISPATCH2_BEGIN(x,y) ecl_times(x, y->complex.imag)); } CASE_COMPLEX_COMPLEX { - cl_object z11 = ecl_times(x->complex.real, y->complex.real); - cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); - cl_object z21 = ecl_times(x->complex.imag, y->complex.real); - cl_object z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + cl_object z11 = ecl_times(x->complex.real, y->complex.real); + cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); + cl_object z21 = ecl_times(x->complex.imag, y->complex.real); + cl_object z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); } CASE_UNKNOWN(@[*],x,y,@[number]); } @@ -175,162 +175,162 @@ MATH_DISPATCH2_END; cl_object ecl_times(cl_object x, cl_object y) { - cl_object z, z1; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_fix(y, ecl_fixnum(x)); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_times_fix(x, ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_times_fix(x, ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.num, y); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.num); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.num, y); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.num); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_singlefloat: { - float fx = ecl_single_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(fx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(fx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(fx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(fx * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_singlefloat: { + float fx = ecl_single_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(fx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(fx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(fx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(fx * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(fx * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(fx * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } - case t_doublefloat: { - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } + case t_doublefloat: { + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); #endif - case t_complex: { - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_times(x, y->complex.real), + case t_complex: { + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_times(x, y->complex.real), ecl_times(x, y->complex.imag)); - } - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + } + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double lx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(lx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(lx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(lx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(lx * ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(lx * ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + case t_longfloat: { + long double lx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(lx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(lx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(lx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(lx * ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(lx * ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #endif - case t_complex: - { - cl_object z11, z12, z21, z22; + case t_complex: + { + cl_object z11, z12, z21, z22; - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z11 = ecl_times(x->complex.real, y->complex.real); - z12 = ecl_times(x->complex.imag, y->complex.imag); - z21 = ecl_times(x->complex.imag, y->complex.real); - z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); - } - default: - FEwrong_type_nth_arg(@[*], 1, x, @[number]); - } + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z11 = ecl_times(x->complex.real, y->complex.real); + z12 = ecl_times(x->complex.imag, y->complex.imag); + z21 = ecl_times(x->complex.imag, y->complex.real); + z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + } + default: + FEwrong_type_nth_arg(@[*], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/truncate.d b/src/c/numbers/truncate.d index 9f93d8047..5665e8b21 100644 --- a/src/c/numbers/truncate.d +++ b/src/c/numbers/truncate.d @@ -25,63 +25,63 @@ cl_object ecl_truncate1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - if (ecl_plusp(x->ratio.num)) - return ecl_floor1(x); - else - return ecl_ceiling1(x); - case t_singlefloat: { - float d = ecl_single_float(x); - float y = d > 0? floorf(d) : ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = d > 0? floor(d) : ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + if (ecl_plusp(x->ratio.num)) + return ecl_floor1(x); + else + return ecl_ceiling1(x); + case t_singlefloat: { + float d = ecl_single_float(x); + float y = d > 0? floorf(d) : ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = d > 0? floor(d) : ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = d > 0? floorl(d) : ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = d > 0? floorl(d) : ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: + default: FEwrong_type_nth_arg(@[truncate],1,x,@[real]); - } - { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return2(the_env, v0, v1); - } + } + { + const cl_env_ptr the_env = ecl_process_env(); + ecl_return2(the_env, v0, v1); + } } cl_object ecl_truncate2(cl_object x, cl_object y) { - if (ecl_plusp(x) != ecl_plusp(y)) - return ecl_ceiling2(x, y); - else - return ecl_floor2(x, y); + if (ecl_plusp(x) != ecl_plusp(y)) + return ecl_ceiling2(x, y); + else + return ecl_floor2(x, y); } @(defun truncate (x &optional (y OBJNULL)) @ - if (narg == 1) - return ecl_truncate1(x); - else - return ecl_truncate2(x, y); + if (narg == 1) + return ecl_truncate1(x); + else + return ecl_truncate2(x, y); @) diff --git a/src/c/numbers/zerop.d b/src/c/numbers/zerop.d index 26731578e..a06f6d897 100644 --- a/src/c/numbers/zerop.d +++ b/src/c/numbers/zerop.d @@ -20,8 +20,8 @@ cl_object cl_zerop(cl_object x) -{ /* INV: ecl_zerop() checks type */ - @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_zerop() checks type */ + @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)) } static int diff --git a/src/c/package.d b/src/c/package.d index 60b8427c2..3a5336b27 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -39,38 +39,38 @@ static cl_object find_symbol_inner(cl_object name, cl_object p, int *intern_flag static void FEpackage_error(const char *message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ - @':package', package); /* extra arguments */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ + @':package', package); /* extra arguments */ } void CEpackage_error(const char *message, const char *continue_message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - make_constant_base_string(continue_message), - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), - @':package', package); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + make_constant_base_string(continue_message), + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), + @':package', package); } static bool member_string_eq(cl_object x, cl_object l) { - /* INV: l is a proper list */ - loop_for_on_unsafe(l) { - if (ecl_string_eq(x, ECL_CONS_CAR(l))) - return TRUE; - } end_loop_for_on_unsafe(l); - return FALSE; + /* INV: l is a proper list */ + loop_for_on_unsafe(l) { + if (ecl_string_eq(x, ECL_CONS_CAR(l))) + return TRUE; + } end_loop_for_on_unsafe(l); + return FALSE; } #if defined(__cplusplus) || (defined(__GNUC__) && !defined(__STRICT_ANSI__)) @@ -82,33 +82,33 @@ member_string_eq(cl_object x, cl_object l) static INLINE void symbol_remove_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == p) - s->symbol.hpack = ECL_NIL; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == p) + s->symbol.hpack = ECL_NIL; } static INLINE void symbol_add_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == ECL_NIL) - s->symbol.hpack = p; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == ECL_NIL) + s->symbol.hpack = p; } /* - ecl_make_package(n, ns, ul) makes a package with name n, - which must be a string or a symbol, - and nicknames ns, which must be a list of strings or symbols, - and uses packages in list ul, which must be a list of packages - or package names i.e. strings or symbols. + ecl_make_package(n, ns, ul) makes a package with name n, + which must be a string or a symbol, + and nicknames ns, which must be a list of strings or symbols, + and uses packages in list ul, which must be a list of packages + or package names i.e. strings or symbols. */ static cl_object make_package_hashtable() { - return cl__make_hash_table(@'package', /* package hash table */ - ecl_make_fixnum(128), /* initial size */ + return cl__make_hash_table(@'package', /* package hash table */ + ecl_make_fixnum(128), /* initial size */ cl_core.rehash_size, cl_core.rehash_threshold); } @@ -118,13 +118,13 @@ alloc_package(cl_object name) { cl_object p = ecl_alloc_object(t_package); p->pack.internal = make_package_hashtable(); - p->pack.external = make_package_hashtable(); + p->pack.external = make_package_hashtable(); p->pack.name = name; - p->pack.nicknames = ECL_NIL; - p->pack.shadowings = ECL_NIL; - p->pack.uses = ECL_NIL; - p->pack.usedby = ECL_NIL; - p->pack.locked = FALSE; + p->pack.nicknames = ECL_NIL; + p->pack.shadowings = ECL_NIL; + p->pack.uses = ECL_NIL; + p->pack.usedby = ECL_NIL; + p->pack.locked = FALSE; return p; } @@ -148,21 +148,21 @@ find_pending_package(cl_env_ptr env, cl_object name, cl_object nicknames) { if (ecl_option_values[ECL_OPT_BOOTED]) { cl_object l = env->packages_to_be_created; - while (!Null(l)) { - cl_object pair = ECL_CONS_CAR(l); - cl_object other_name = ECL_CONS_CAR(pair); - if (ecl_equal(other_name, name) || - _ecl_funcall5(@'member', other_name, nicknames, - @':test', @'string=') != ECL_NIL) - { - cl_object x = ECL_CONS_CDR(pair); + while (!Null(l)) { + cl_object pair = ECL_CONS_CAR(l); + cl_object other_name = ECL_CONS_CAR(pair); + if (ecl_equal(other_name, name) || + _ecl_funcall5(@'member', other_name, nicknames, + @':test', @'string=') != ECL_NIL) + { + cl_object x = ECL_CONS_CDR(pair); env->packages_to_be_created = ecl_remove_eq(pair, env->packages_to_be_created); return x; - } - l = ECL_CONS_CDR(l); - } + } + l = ECL_CONS_CDR(l); + } } return ECL_NIL; } @@ -191,15 +191,15 @@ cl_object ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) { const cl_env_ptr env = ecl_process_env(); - cl_object x, other = ECL_NIL; + cl_object x, other = ECL_NIL; /* Type checking, coercions, and the like, happen before we * acquire the lock */ - name = cl_string(name); + name = cl_string(name); nicknames = process_nicknames(nicknames); use_list = process_package_list(use_list); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { /* Find a similarly named package in the list of * packages to be created and use it or try to build a * new package */ @@ -237,7 +237,7 @@ ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) other, 1, name); return other; } - return x; + return x; } cl_object @@ -245,16 +245,16 @@ ecl_rename_package(cl_object x, cl_object name, cl_object nicknames) { bool error; - name = cl_string(name); + name = cl_string(name); nicknames = process_nicknames(nicknames); - x = si_coerce_to_package(x); - if (x->pack.locked) { - CEpackage_error("Cannot rename locked package ~S.", - "Ignore lock and proceed", x, 0); + x = si_coerce_to_package(x); + if (x->pack.locked) { + CEpackage_error("Cannot rename locked package ~S.", + "Ignore lock and proceed", x, 0); } nicknames = ecl_cons(name, nicknames); error = 0; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { cl_object l; for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object nick = ECL_CONS_CAR(l); @@ -269,104 +269,104 @@ ecl_rename_package(cl_object x, cl_object name, cl_object nicknames) x->pack.name = name; x->pack.nicknames = ECL_CONS_CDR(nicknames); } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; if (error) { FEpackage_error("A package with name ~S already exists.", x, 1, name); } - return x; + return x; } /* - ecl_find_package_nolock(n) seaches for a package with name n, where n is - a valid string designator, or simply outputs n if it is a - package. + ecl_find_package_nolock(n) seaches for a package with name n, where n is + a valid string designator, or simply outputs n if it is a + package. - This is not a locking routine and someone may replace the list of - packages while we are scanning it. Nevertheless, the list IS NOT - be destructively modified, which means that we are on the safe side. - Routines which need to ensure that the package list remains constant - should enforce a global lock with PACKAGE_OP_LOCK(). + This is not a locking routine and someone may replace the list of + packages while we are scanning it. Nevertheless, the list IS NOT + be destructively modified, which means that we are on the safe side. + Routines which need to ensure that the package list remains constant + should enforce a global lock with PACKAGE_OP_LOCK(). */ cl_object ecl_find_package_nolock(cl_object name) { - cl_object l, p; + cl_object l, p; - if (ECL_PACKAGEP(name)) - return name; - name = cl_string(name); - l = cl_core.packages; - loop_for_on_unsafe(l) { - p = ECL_CONS_CAR(l); - if (ecl_string_eq(name, p->pack.name)) - return p; - if (member_string_eq(name, p->pack.nicknames)) - return p; - } end_loop_for_on_unsafe(l); + if (ECL_PACKAGEP(name)) + return name; + name = cl_string(name); + l = cl_core.packages; + loop_for_on_unsafe(l) { + p = ECL_CONS_CAR(l); + if (ecl_string_eq(name, p->pack.name)) + return p; + if (member_string_eq(name, p->pack.nicknames)) + return p; + } end_loop_for_on_unsafe(l); #ifdef ECL_RELATIVE_PACKAGE_NAMES - /* Note that this function may actually be called _before_ symbols are set up - * are bound! */ - if (ecl_option_values[ECL_OPT_BOOTED] && - ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { - return si_find_relative_package(1, name); - } + /* Note that this function may actually be called _before_ symbols are set up + * are bound! */ + if (ecl_option_values[ECL_OPT_BOOTED] && + ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { + return si_find_relative_package(1, name); + } #endif - return ECL_NIL; + return ECL_NIL; } cl_object ecl_find_package(const char *p) { - ecl_def_ct_base_string(pack_name,p,strlen(p),,); - return cl_find_package(pack_name); + ecl_def_ct_base_string(pack_name,p,strlen(p),,); + return cl_find_package(pack_name); } cl_object si_coerce_to_package(cl_object p) { - /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package - nor a string */ - cl_object pp = ecl_find_package_nolock(p); - if (Null(pp)) { - FEpackage_error("There exists no package with name ~S", p, 0); - } - @(return pp); + /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package + nor a string */ + cl_object pp = ecl_find_package_nolock(p); + if (Null(pp)) { + FEpackage_error("There exists no package with name ~S", p, 0); + } + @(return pp); } cl_object ecl_current_package(void) { - cl_object x = ecl_symbol_value(@'*package*'); - unlikely_if (!ECL_PACKAGEP(x)) { - const cl_env_ptr env = ecl_process_env(); - ECL_SETQ(env, @'*package*', cl_core.user_package); - FEerror("The value of *PACKAGE*, ~S, was not a package", - 1, x); - } - return x; + cl_object x = ecl_symbol_value(@'*package*'); + unlikely_if (!ECL_PACKAGEP(x)) { + const cl_env_ptr env = ecl_process_env(); + ECL_SETQ(env, @'*package*', cl_core.user_package); + FEerror("The value of *PACKAGE*, ~S, was not a package", + 1, x); + } + return x; } /* - Ecl_Intern(st, p) interns string st in package p. + Ecl_Intern(st, p) interns string st in package p. */ cl_object _ecl_intern(const char *s, cl_object p) { - int intern_flag; - cl_object str = make_constant_base_string(s); - return ecl_intern(str, p, &intern_flag); + int intern_flag; + cl_object str = make_constant_base_string(s); + return ecl_intern(str, p, &intern_flag); } cl_object ecl_intern(cl_object name, cl_object p, int *intern_flag) { - cl_object s; + cl_object s; bool error, ignore_error = 0; if (ecl_unlikely(!ECL_STRINGP(name))) FEwrong_type_nth_arg(@[intern], 1, name, @[string]); - p = si_coerce_to_package(p); + p = si_coerce_to_package(p); AGAIN: ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { s = find_symbol_inner(name, p, intern_flag); @@ -392,56 +392,56 @@ ecl_intern(cl_object name, cl_object p, int *intern_flag) } ECL_WITH_GLOBAL_ENV_WRLOCK_END; if (error) { CEpackage_error("Cannot intern symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, name, p); + "Ignore lock and proceed", p, 2, name, p); ignore_error = 1; goto AGAIN; } - return s; + return s; } /* - find_symbol_inner(st, len, p) searches for string st of length - len in package p. + find_symbol_inner(st, len, p) searches for string st of length + len in package p. */ static cl_object find_symbol_inner(cl_object name, cl_object p, int *intern_flag) { - cl_object s, ul; + cl_object s, ul; - s = ecl_gethash_safe(name, p->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_EXTERNAL; - goto OUTPUT; - } - if (p == cl_core.keyword_package) - goto NOTHING; - s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INTERNAL; - goto OUTPUT; - } - ul = p->pack.uses; - loop_for_on_unsafe(ul) { - s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INHERITED; - goto OUTPUT; - } - } end_loop_for_on_unsafe(ul); + s = ecl_gethash_safe(name, p->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_EXTERNAL; + goto OUTPUT; + } + if (p == cl_core.keyword_package) + goto NOTHING; + s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INTERNAL; + goto OUTPUT; + } + ul = p->pack.uses; + loop_for_on_unsafe(ul) { + s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INHERITED; + goto OUTPUT; + } + } end_loop_for_on_unsafe(ul); NOTHING: - *intern_flag = 0; - s = ECL_NIL; + *intern_flag = 0; + s = ECL_NIL; OUTPUT: - return s; + return s; } cl_object ecl_find_symbol(cl_object n, cl_object p, int *intern_flag) { cl_object s; - if (ecl_unlikely(!ECL_STRINGP(n))) + if (ecl_unlikely(!ECL_STRINGP(n))) FEwrong_type_nth_arg(@[find-symbol], 1, n, @[string]); - p = si_coerce_to_package(p); + p = si_coerce_to_package(p); ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(ecl_process_env()) { s = find_symbol_inner(n, p, intern_flag); } ECL_WITH_GLOBAL_ENV_RDLOCK_END; @@ -470,17 +470,17 @@ potential_unintern_conflict(cl_object name, cl_object s, cl_object p) bool ecl_unintern(cl_object s, cl_object p) { - cl_object conflict; - bool output = FALSE; - cl_object name = ecl_symbol_name(s); + cl_object conflict; + bool output = FALSE; + cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } + p = si_coerce_to_package(p); + if (p->pack.locked) { + CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } conflict = ECL_NIL; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { cl_object hash = p->pack.internal; cl_object x = ecl_gethash_safe(name, hash, OBJNULL); if (x != s) { @@ -509,7 +509,7 @@ ecl_unintern(cl_object s, cl_object p) "a name conflict.", p, 4, s, p, ECL_CONS_CAR(conflict), ECL_CONS_CDR(conflict)); } - return output; + return output; } static cl_object @@ -531,12 +531,12 @@ potential_export_conflict(cl_object name, cl_object s, cl_object p) void cl_export2(cl_object s, cl_object p) { - int intern_flag, error; - cl_object other_p, name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot export symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + int intern_flag, error; + cl_object other_p, name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot export symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); AGAIN: ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { cl_object x = find_symbol_inner(name, p, &intern_flag); @@ -554,18 +554,18 @@ cl_export2(cl_object s, cl_object p) p->pack.external = _ecl_sethash(name, p->pack.external, s); error = 0; } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; if (error == 1) { - CEpackage_error("The symbol ~S is not accessible from ~S " + CEpackage_error("The symbol ~S is not accessible from ~S " "and cannot be exported.", - "Import the symbol in the package and proceed.", - p, 2, s, p); + "Import the symbol in the package and proceed.", + p, 2, s, p); cl_import2(s, p); goto AGAIN; } else if (error == 2) { - FEpackage_error("Cannot export the symbol ~S from ~S,~%" - "because there is already a symbol with the same name~%" - "in the package.", p, 2, s, p); + FEpackage_error("Cannot export the symbol ~S from ~S,~%" + "because there is already a symbol with the same name~%" + "in the package.", p, 2, s, p); } else if (error == 3) { FEpackage_error("Cannot export the symbol ~S~%" "from ~S,~%" @@ -577,37 +577,37 @@ cl_export2(cl_object s, cl_object p) cl_object cl_delete_package(cl_object p) { - cl_object hash, l; - cl_index i; + cl_object hash, l; + cl_index i; - /* 1) Try to remove the package from the global list */ - p = ecl_find_package_nolock(p); - if (Null(p)) { - CEpackage_error("Package ~S not found. Cannot delete it.", - "Ignore error and continue", p, 0); - @(return ECL_NIL); - } - if (p->pack.locked) - CEpackage_error("Cannot delete locked package ~S.", - "Ignore lock and proceed", p, 0); - if (p == cl_core.lisp_package || p == cl_core.keyword_package) { - FEpackage_error("Cannot remove package ~S", p, 0); - } + /* 1) Try to remove the package from the global list */ + p = ecl_find_package_nolock(p); + if (Null(p)) { + CEpackage_error("Package ~S not found. Cannot delete it.", + "Ignore error and continue", p, 0); + @(return ECL_NIL); + } + if (p->pack.locked) + CEpackage_error("Cannot delete locked package ~S.", + "Ignore lock and proceed", p, 0); + if (p == cl_core.lisp_package || p == cl_core.keyword_package) { + FEpackage_error("Cannot remove package ~S", p, 0); + } - /* 2) Now remove the package from the other packages that use it - * and empty the package. - */ - if (Null(p->pack.name)) { - @(return ECL_NIL) - } + /* 2) Now remove the package from the other packages that use it + * and empty the package. + */ + if (Null(p->pack.name)) { + @(return ECL_NIL) + } while (!Null(l = p->pack.uses)) { - ecl_unuse_package(ECL_CONS_CAR(l), p); - } + ecl_unuse_package(ECL_CONS_CAR(l), p); + } while (!Null(l = p->pack.usedby)) { - ecl_unuse_package(p, ECL_CONS_CAR(l)); - } + ecl_unuse_package(p, ECL_CONS_CAR(l)); + } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) if (hash->hash.data[i].key != OBJNULL) { cl_object s = hash->hash.data[i].value; @@ -625,24 +625,24 @@ cl_delete_package(cl_object p) /* 2) Only at the end, remove the package from the list of packages. */ cl_core.packages = ecl_remove_eq(p, cl_core.packages); } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return ECL_T) + @(return ECL_T) } void cl_unexport2(cl_object s, cl_object p) { - cl_object name = ecl_symbol_name(s); - bool error; - p = si_coerce_to_package(p); - if (p == cl_core.keyword_package) { - FEpackage_error("Cannot unexport a symbol from the keyword package.", - cl_core.keyword_package, 0); + cl_object name = ecl_symbol_name(s); + bool error; + p = si_coerce_to_package(p); + if (p == cl_core.keyword_package) { + FEpackage_error("Cannot unexport a symbol from the keyword package.", + cl_core.keyword_package, 0); } - if (p->pack.locked) { - CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + if (p->pack.locked) { + CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { int intern_flag; cl_object x = find_symbol_inner(name, p, &intern_flag); if (intern_flag == 0 || x != s) { @@ -658,23 +658,23 @@ cl_unexport2(cl_object s, cl_object p) } } ECL_WITH_GLOBAL_ENV_WRLOCK_END; if (error) { - FEpackage_error("Cannot unexport ~S because it does not " + FEpackage_error("Cannot unexport ~S because it does not " "belong to package ~S.", - p, 2, s, p); + p, 2, s, p); } } void cl_import2(cl_object s, cl_object p) { - int intern_flag, error, ignore_error = 0; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot import symbol ~S into locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + int intern_flag, error, ignore_error = 0; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) { + CEpackage_error("Cannot import symbol ~S into locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { cl_object x = find_symbol_inner(name, p, &intern_flag); if (intern_flag) { if (x != s && !ignore_error) { @@ -705,16 +705,16 @@ cl_import2(cl_object s, cl_object p) void ecl_shadowing_import(cl_object s, cl_object p) { - int intern_flag; - cl_object x; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadowing-import symbol ~S into " + int intern_flag; + cl_object x; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot shadowing-import symbol ~S into " "locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + "Ignore lock and proceed", p, 2, s, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { x = find_symbol_inner(name, p, &intern_flag); if (intern_flag && intern_flag != ECL_INHERITED) { if (x == s) { @@ -742,16 +742,16 @@ ecl_shadowing_import(cl_object s, cl_object p) void ecl_shadow(cl_object s, cl_object p) { - int intern_flag; - cl_object x; + int intern_flag; + cl_object x; - /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ - s = cl_string(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ + s = cl_string(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { x = find_symbol_inner(s, p, &intern_flag); if (intern_flag != ECL_INTERNAL && intern_flag != ECL_EXTERNAL) { x = cl_make_symbol(s); @@ -765,29 +765,29 @@ ecl_shadow(cl_object s, cl_object p) void ecl_use_package(cl_object x, cl_object p) { - struct ecl_hashtable_entry *hash_entries; - cl_index i, hash_length; + struct ecl_hashtable_entry *hash_entries; + cl_index i, hash_length; cl_object here, there, name; - int intern_flag, error = 0; + int intern_flag, error = 0; - x = si_coerce_to_package(x); - if (x == cl_core.keyword_package) - FEpackage_error("Cannot use keyword package.", + x = si_coerce_to_package(x); + if (x == cl_core.keyword_package) + FEpackage_error("Cannot use keyword package.", cl_core.keyword_package, 0); - p = si_coerce_to_package(p); - if (p == x) - return; - if (ecl_member_eq(x, p->pack.uses)) - return; - if (p == cl_core.keyword_package) - FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", + p = si_coerce_to_package(p); + if (p == x) + return; + if (ecl_member_eq(x, p->pack.uses)) + return; + if (p == cl_core.keyword_package) + FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", cl_core.keyword_package, 0); - if (p->pack.locked) - CEpackage_error("Cannot use package ~S in locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); + if (p->pack.locked) + CEpackage_error("Cannot use package ~S in locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { hash_entries = x->pack.external->hash.data; hash_length = x->pack.external->hash.size; for (i = 0, error = 0; i < hash_length; i++) { @@ -818,12 +818,12 @@ ecl_use_package(cl_object x, cl_object p) void ecl_unuse_package(cl_object x, cl_object p) { - x = si_coerce_to_package(x); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot unuse package ~S from locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); + x = si_coerce_to_package(x); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot unuse package ~S from locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { p->pack.uses = ecl_remove_eq(x, p->pack.uses); x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); @@ -832,275 +832,275 @@ ecl_unuse_package(cl_object x, cl_object p) @(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, ECL_NIL))) @ - /* INV: ecl_make_package() performs type checking */ - @(return ecl_make_package(pack_name, nicknames, use)) + /* INV: ecl_make_package() performs type checking */ + @(return ecl_make_package(pack_name, nicknames, use)) @) cl_object si_select_package(cl_object pack_name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object p = si_coerce_to_package(pack_name); - ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); + const cl_env_ptr the_env = ecl_process_env(); + cl_object p = si_coerce_to_package(pack_name); + ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); } cl_object cl_find_package(cl_object p) { - @(return ecl_find_package_nolock(p)) + @(return ecl_find_package_nolock(p)) } cl_object cl_package_name(cl_object p) { - /* FIXME: name should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.name) + /* FIXME: name should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.name) } cl_object cl_package_nicknames(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.nicknames) + /* FIXME: list should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.nicknames) } @(defun rename_package (pack new_name &o new_nicknames) @ - /* INV: ecl_rename_package() type checks and coerces pack to package */ - @(return ecl_rename_package(pack, new_name, new_nicknames)) + /* INV: ecl_rename_package() type checks and coerces pack to package */ + @(return ecl_rename_package(pack, new_name, new_nicknames)) @) cl_object cl_package_use_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.uses); + return cl_copy_list(si_coerce_to_package(p)->pack.uses); } cl_object cl_package_used_by_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.usedby); + return cl_copy_list(si_coerce_to_package(p)->pack.usedby); } cl_object cl_package_shadowing_symbols(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); + return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); } cl_object si_package_lock(cl_object p, cl_object t) { - bool previous; - p = si_coerce_to_package(p); - previous = p->pack.locked; - p->pack.locked = (t != ECL_NIL); - @(return (previous? ECL_T : ECL_NIL)) + bool previous; + p = si_coerce_to_package(p); + previous = p->pack.locked; + p->pack.locked = (t != ECL_NIL); + @(return (previous? ECL_T : ECL_NIL)) } cl_object cl_list_all_packages() { - return cl_copy_list(cl_core.packages); + return cl_copy_list(cl_core.packages); } @(defun intern (strng &optional (p ecl_current_package()) &aux sym) - int intern_flag; + int intern_flag; @ - sym = ecl_intern(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return sym @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return sym @':external') - if (intern_flag == ECL_INHERITED) - @(return sym @':inherited') - @(return sym ECL_NIL) + sym = ecl_intern(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) + @(return sym @':internal') + if (intern_flag == ECL_EXTERNAL) + @(return sym @':external') + if (intern_flag == ECL_INHERITED) + @(return sym @':inherited') + @(return sym ECL_NIL) @) @(defun find_symbol (strng &optional (p ecl_current_package())) - cl_object x; - int intern_flag; + cl_object x; + int intern_flag; @ - x = ecl_find_symbol(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return x @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return x @':external') - if (intern_flag == ECL_INHERITED) - @(return x @':inherited') - @(return ECL_NIL ECL_NIL) + x = ecl_find_symbol(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) + @(return x @':internal') + if (intern_flag == ECL_EXTERNAL) + @(return x @':external') + if (intern_flag == ECL_INHERITED) + @(return x @':inherited') + @(return ECL_NIL ECL_NIL) @) @(defun unintern (symbl &optional (p ecl_current_package())) @ - @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)) + @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)) @) @(defun export (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_export2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_export2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_export2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_export2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[export],1,symbols, cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun unexport (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_unexport2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_unexport2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_unexport2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_unexport2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[unexport],1,symbols, cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_import2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_import2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_import2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_import2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[import],1,symbols, cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun shadowing_import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - ecl_shadowing_import(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: + switch (ecl_t_of(symbols)) { + case t_symbol: + ecl_shadowing_import(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[shadowing-import],1,symbols, cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun shadow (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { + switch (ecl_t_of(symbols)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_symbol: - case t_character: - /* Arguments to SHADOW may be: string designators ... */ - ecl_shadow(symbols, pack); - break; - case t_list: - /* ... or lists of string designators */ - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadow(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: + case t_base_string: + case t_symbol: + case t_character: + /* Arguments to SHADOW may be: string designators ... */ + ecl_shadow(symbols, pack); + break; + case t_list: + /* ... or lists of string designators */ + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadow(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[shadow],1,symbols, cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun use_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_use_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_use_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: + case t_package: + ecl_use_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_use_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[use-package], 1, pack, ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + } + @(return ECL_T) @) @(defun unuse_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_unuse_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_unuse_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: + case t_package: + ecl_unuse_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_unuse_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: FEwrong_type_nth_arg(@[unuse-package], 1, pack, ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + } + @(return ECL_T) @) cl_object si_package_hash_tables(cl_object p) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object he, hi, u; + const cl_env_ptr the_env = ecl_process_env(); + cl_object he, hi, u; unlikely_if (!ECL_PACKAGEP(p)) FEwrong_type_only_arg(@[si::package-hash-tables], p, @[package]); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { he = si_copy_hash_table(p->pack.external); hi = si_copy_hash_table(p->pack.internal); u = cl_copy_list(p->pack.uses); } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return he hi u) + @(return he hi u) } diff --git a/src/c/pathname.d b/src/c/pathname.d index 39fc61bdd..206b2286b 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -17,9 +17,9 @@ */ /* - O.S. DEPENDENT + O.S. DEPENDENT - This file contains those functions that interpret namestrings. + This file contains those functions that interpret namestrings. */ #include @@ -99,26 +99,26 @@ to_antilocal_case(cl_object str, cl_object cas) static cl_object translate_from_common(cl_object str, cl_object tocase) { - int string_case = ecl_string_case(str); - if (string_case > 0) { /* ALL_UPPER */ - return to_local_case(str, tocase); - } else if (string_case < 0) { /* ALL_LOWER */ - return to_antilocal_case(str, tocase); - } else { /* Mixed case goes unchanged */ - return str; - } + int string_case = ecl_string_case(str); + if (string_case > 0) { /* ALL_UPPER */ + return to_local_case(str, tocase); + } else if (string_case < 0) { /* ALL_LOWER */ + return to_antilocal_case(str, tocase); + } else { /* Mixed case goes unchanged */ + return str; + } } static cl_object translate_to_common(cl_object str, cl_object fromcase) { - if (in_local_case_p(str, fromcase)) { - return cl_string_upcase(1, str); - } else if (in_antilocal_case_p(str, fromcase)) { - return cl_string_downcase(1, str); - } else { - return str; - } + if (in_local_case_p(str, fromcase)) { + return cl_string_upcase(1, str); + } else if (in_antilocal_case_p(str, fromcase)) { + return cl_string_downcase(1, str); + } else { + return str; + } } static cl_object @@ -133,10 +133,10 @@ translate_component_case(cl_object str, cl_object fromcase, cl_object tocase) } else if (tocase == fromcase) { return str; } else if (tocase == @':common') { - return translate_to_common(str, fromcase); - } else if (fromcase == @':common') { - return translate_from_common(str, tocase); - } else { + return translate_to_common(str, fromcase); + } else if (fromcase == @':common') { + return translate_from_common(str, tocase); + } else { str = translate_to_common(str, fromcase); return translate_from_common(str, tocase); } @@ -145,177 +145,177 @@ translate_component_case(cl_object str, cl_object fromcase, cl_object tocase) static cl_object translate_list_case(cl_object list, cl_object fromcase, cl_object tocase) { - /* If the argument is really a list, translate all strings in it and - * return this new list, else assume it is a string and translate it. - */ - if (!CONSP(list)) { - return translate_component_case(list, fromcase, tocase); - } else { - cl_object l; - list = cl_copy_list(list); - for (l = list; !ecl_endp(l); l = CDR(l)) { - /* It is safe to pass anything to translate_component_case, - * because it will only transform strings, leaving other - * object (such as symbols) unchanged.*/ - cl_object name = ECL_CONS_CAR(l); + /* If the argument is really a list, translate all strings in it and + * return this new list, else assume it is a string and translate it. + */ + if (!CONSP(list)) { + return translate_component_case(list, fromcase, tocase); + } else { + cl_object l; + list = cl_copy_list(list); + for (l = list; !ecl_endp(l); l = CDR(l)) { + /* It is safe to pass anything to translate_component_case, + * because it will only transform strings, leaving other + * object (such as symbols) unchanged.*/ + cl_object name = ECL_CONS_CAR(l); name = ECL_LISTP(name)? translate_list_case(name, fromcase, tocase) : translate_component_case(name, fromcase, tocase); - ECL_RPLACA(l, name); - } - return list; - } + ECL_RPLACA(l, name); + } + return list; + } } static void push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end) { - string = cl_string(string); - while (start < end) { - ecl_string_push_extend(buffer, ecl_char(string, start)); - start++; - } + string = cl_string(string); + while (start < end) { + ecl_string_push_extend(buffer, ecl_char(string, start)); + start++; + } } static void push_string(cl_object buffer, cl_object string) { - push_substring(buffer, string, 0, ecl_length(string)); + push_substring(buffer, string, 0, ecl_length(string)); } static cl_object destructively_check_directory(cl_object directory, bool logical, bool delete_back) { - /* This function performs two tasks - * 1) It ensures that the list is a valid directory list - * 2) It ensures that all strings in the list are valid C strings without fill pointer - * All strings are copied, thus avoiding problems with the user modifying the - * list that was passed to MAKE-PATHNAME. + /* This function performs two tasks + * 1) It ensures that the list is a valid directory list + * 2) It ensures that all strings in the list are valid C strings without fill pointer + * All strings are copied, thus avoiding problems with the user modifying the + * list that was passed to MAKE-PATHNAME. * 3) Redundant :back are removed. - */ - /* INV: directory is always a list */ - cl_object ptr; - int i; + */ + /* INV: directory is always a list */ + cl_object ptr; + int i; - if (!LISTP(directory)) - return @':error'; - if (Null(directory)) - return directory; - if (ECL_CONS_CAR(directory) != @':absolute' && - ECL_CONS_CAR(directory) != @':relative') - return @':error'; + if (!LISTP(directory)) + return @':error'; + if (Null(directory)) + return directory; + if (ECL_CONS_CAR(directory) != @':absolute' && + ECL_CONS_CAR(directory) != @':relative') + return @':error'; BEGIN: - for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { - cl_object item = ECL_CONS_CAR(ptr); - if (item == @':back') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - if (delete_back && i >= 2) { + for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { + cl_object item = ECL_CONS_CAR(ptr); + if (item == @':back') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + if (delete_back && i >= 2) { cl_object next = ECL_CONS_CDR(ptr); ptr = ecl_nthcdr(i-2, directory); - ECL_RPLACD(ptr, next); + ECL_RPLACD(ptr, next); i = i-2; } - } else if (item == @':up') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - } else if (item == @':relative' || item == @':absolute') { - if (i > 0) - return @':error'; - } else if (ecl_stringp(item)) { - cl_index l = ecl_length(item); - item = cl_copy_seq(item); - ECL_RPLACA(ptr, item); - if (logical) - continue; - if (l && ecl_char(item,0) == '.') { - if (l == 1) { - /* Single dot */ - if (i == 0) - return @':error'; - ECL_RPLACD(ecl_nthcdr(--i, directory), - ECL_CONS_CDR(ptr)); - } else if (l == 2 && ecl_char(item,1) == '.') { - ECL_RPLACA(ptr, @':up'); - goto BEGIN; - } - } - } else if (item != @':wild' && item != @':wild-inferiors') { - return @':error'; - } - } - return directory; + } else if (item == @':up') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + } else if (item == @':relative' || item == @':absolute') { + if (i > 0) + return @':error'; + } else if (ecl_stringp(item)) { + cl_index l = ecl_length(item); + item = cl_copy_seq(item); + ECL_RPLACA(ptr, item); + if (logical) + continue; + if (l && ecl_char(item,0) == '.') { + if (l == 1) { + /* Single dot */ + if (i == 0) + return @':error'; + ECL_RPLACD(ecl_nthcdr(--i, directory), + ECL_CONS_CDR(ptr)); + } else if (l == 2 && ecl_char(item,1) == '.') { + ECL_RPLACA(ptr, @':up'); + goto BEGIN; + } + } + } else if (item != @':wild' && item != @':wild-inferiors') { + return @':error'; + } + } + return directory; } cl_object ecl_make_pathname(cl_object host, cl_object device, cl_object directory, - cl_object name, cl_object type, cl_object version, + cl_object name, cl_object type, cl_object version, cl_object fromcase) { - cl_object x, p, component; + cl_object x, p, component; - p = ecl_alloc_object(t_pathname); - if (ecl_stringp(host)) - p->pathname.logical = ecl_logical_hostname_p(host); - else if (host == ECL_NIL) - p->pathname.logical = FALSE; - else { - x = directory; - component = @':host'; - goto ERROR; - } - if (device != ECL_NIL && device != @':unspecific' && - !(!p->pathname.logical && ecl_stringp(device))) { - x = device; - component = @':device'; - goto ERROR; - } - if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { - x = name; - component = @':name'; - goto ERROR; - } - if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { - x = type; - component = @':type'; - goto ERROR; - } - if (version != @':unspecific' && version != @':newest' && - version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) - { - x = version; - component = @':version'; - ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); - } - switch (ecl_t_of(directory)) { + p = ecl_alloc_object(t_pathname); + if (ecl_stringp(host)) + p->pathname.logical = ecl_logical_hostname_p(host); + else if (host == ECL_NIL) + p->pathname.logical = FALSE; + else { + x = directory; + component = @':host'; + goto ERROR; + } + if (device != ECL_NIL && device != @':unspecific' && + !(!p->pathname.logical && ecl_stringp(device))) { + x = device; + component = @':device'; + goto ERROR; + } + if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { + x = name; + component = @':name'; + goto ERROR; + } + if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { + x = type; + component = @':type'; + goto ERROR; + } + if (version != @':unspecific' && version != @':newest' && + version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) + { + x = version; + component = @':version'; + ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); + } + switch (ecl_t_of(directory)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - directory = cl_list(2, @':absolute', directory); - break; - case t_symbol: - if (directory == @':wild') { - directory = cl_list(2, @':absolute', @':wild-inferiors'); - break; - } - x = directory; - component = @':directory'; - goto ERROR; - case t_list: - directory = cl_copy_list(directory); - break; - default: - x = directory; - component = @':directory'; - goto ERROR; - } + case t_base_string: + directory = cl_list(2, @':absolute', directory); + break; + case t_symbol: + if (directory == @':wild') { + directory = cl_list(2, @':absolute', @':wild-inferiors'); + break; + } + x = directory; + component = @':directory'; + goto ERROR; + case t_list: + directory = cl_copy_list(directory); + break; + default: + x = directory; + component = @':directory'; + goto ERROR; + } p->pathname.host = host; { cl_object tocase = normalize_case(p, @':local'); @@ -328,7 +328,7 @@ ecl_make_pathname(cl_object host, cl_object device, cl_object directory, p->pathname.device = translate_component_case(device, fromcase, tocase); p->pathname.directory = - directory = + directory = translate_list_case(directory, fromcase, tocase); p->pathname.name = translate_component_case(name, fromcase, tocase); @@ -336,41 +336,41 @@ ecl_make_pathname(cl_object host, cl_object device, cl_object directory, translate_component_case(type, fromcase, tocase); p->pathname.version = version; } - directory = destructively_check_directory(directory, p->pathname.logical, 0); + directory = destructively_check_directory(directory, p->pathname.logical, 0); unlikely_if (directory == @':error') { - cl_error(3, @'file-error', @':pathname', p); - } - p->pathname.directory = directory; - return(p); + cl_error(3, @'file-error', @':pathname', p); + } + p->pathname.directory = directory; + return(p); } static cl_object tilde_expand(cl_object pathname) { - /* - * If the pathname is a physical one, without hostname, without device - * and the first element is either a tilde '~' or '~' followed by - * a user name, we merge the user homedir pathname with this one. - */ - cl_object directory, head; - if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL - || pathname->pathname.device != ECL_NIL) { - return pathname; - } - directory = pathname->pathname.directory; - if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' - || ECL_CONS_CDR(directory) == ECL_NIL) { - return pathname; - } - head = CADR(directory); - if (ecl_stringp(head) && ecl_length(head) > 0 && - ecl_char(head,0) == '~') { - /* Remove the tilde component */ - ECL_RPLACD(directory, CDDR(directory)); - pathname = cl_merge_pathnames(2, pathname, - ecl_homedir_pathname(head)); - } - return pathname; + /* + * If the pathname is a physical one, without hostname, without device + * and the first element is either a tilde '~' or '~' followed by + * a user name, we merge the user homedir pathname with this one. + */ + cl_object directory, head; + if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL + || pathname->pathname.device != ECL_NIL) { + return pathname; + } + directory = pathname->pathname.directory; + if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' + || ECL_CONS_CDR(directory) == ECL_NIL) { + return pathname; + } + head = CADR(directory); + if (ecl_stringp(head) && ecl_length(head) > 0 && + ecl_char(head,0) == '~') { + /* Remove the tilde component */ + ECL_RPLACD(directory, CDDR(directory)); + pathname = cl_merge_pathnames(2, pathname, + ecl_homedir_pathname(head)); + } + return pathname; } #define WORD_INCLUDE_DELIM 1 @@ -385,7 +385,7 @@ tilde_expand(cl_object pathname) static cl_object make_one(cl_object s, cl_index start, cl_index end) { - return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); + return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); } static int is_colon(int c) { return c == ':'; } @@ -396,93 +396,93 @@ static int is_null(int c) { return c == '\0'; } /* * Parses a word from string `S' until either: - * 1) character `DELIM' is found - * 2) end of string is reached - * 3) a non valid character is found + * 1) character `DELIM' is found + * 2) end of string is reached + * 3) a non valid character is found * Output is either - * 1) :error in case (3) above - * 2) :wild, :wild-inferiors, :up - * 3) "" or ECL_NIL when word has no elements - * 5) A non empty string + * 1) :error in case (3) above + * 2) :wild, :wild-inferiors, :up + * 3) "" or ECL_NIL when word has no elements + * 5) A non empty string */ static cl_object parse_word(cl_object s, delim_fn delim, int flags, cl_index start, - cl_index end, cl_index *end_of_word) + cl_index end, cl_index *end_of_word) { - cl_index i, j, last_delim = end; - bool wild_inferiors = FALSE; + cl_index i, j, last_delim = end; + bool wild_inferiors = FALSE; - i = j = start; - for (; i < end; i++) { - bool valid_char; - cl_index c = ecl_char(s, i); - if (delim(c)) { - if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { - /* Leading dot is included */ - continue; - } - last_delim = i; - if (!(flags & WORD_SEARCH_LAST_DOT)) { - break; - } - } - if (c == '*') { - if (!(flags & WORD_ALLOW_ASTERISK)) - valid_char = FALSE; /* Asterisks not allowed in this word */ - else { - wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); - valid_char = TRUE; /* single "*" */ - } - } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { - valid_char = 0; - } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { - valid_char = 0; - } else { - valid_char = c != 0; - } - if (!valid_char) { - *end_of_word = start; - return @':error'; - } - } - if (i > last_delim) { - /* Go back to the position of the last delimiter */ - i = last_delim; - } - if (i < end) { - *end_of_word = i+1; - } else { - *end_of_word = end; - /* We have reached the end of the string without finding - the proper delimiter */ - if (flags & WORD_INCLUDE_DELIM) { - *end_of_word = start; - return ECL_NIL; - } - } - switch(i-j) { - case 0: - if (flags & WORD_EMPTY_IS_NIL) - return ECL_NIL; - return cl_core.null_string; - case 1: - if (ecl_char(s,j) == '*') - return @':wild'; - break; - case 2: { - cl_index c0 = ecl_char(s,j); - cl_index c1 = ecl_char(s,j+1); - if (c0 == '*' && c1 == '*') - return @':wild-inferiors'; - if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') - return @':up'; - break; - } - default: - if (wild_inferiors) /* '**' surrounded by other characters */ - return @':error'; - } - return make_one(s, j, i); + i = j = start; + for (; i < end; i++) { + bool valid_char; + cl_index c = ecl_char(s, i); + if (delim(c)) { + if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { + /* Leading dot is included */ + continue; + } + last_delim = i; + if (!(flags & WORD_SEARCH_LAST_DOT)) { + break; + } + } + if (c == '*') { + if (!(flags & WORD_ALLOW_ASTERISK)) + valid_char = FALSE; /* Asterisks not allowed in this word */ + else { + wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); + valid_char = TRUE; /* single "*" */ + } + } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { + valid_char = 0; + } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { + valid_char = 0; + } else { + valid_char = c != 0; + } + if (!valid_char) { + *end_of_word = start; + return @':error'; + } + } + if (i > last_delim) { + /* Go back to the position of the last delimiter */ + i = last_delim; + } + if (i < end) { + *end_of_word = i+1; + } else { + *end_of_word = end; + /* We have reached the end of the string without finding + the proper delimiter */ + if (flags & WORD_INCLUDE_DELIM) { + *end_of_word = start; + return ECL_NIL; + } + } + switch(i-j) { + case 0: + if (flags & WORD_EMPTY_IS_NIL) + return ECL_NIL; + return cl_core.null_string; + case 1: + if (ecl_char(s,j) == '*') + return @':wild'; + break; + case 2: { + cl_index c0 = ecl_char(s,j); + cl_index c1 = ecl_char(s,j+1); + if (c0 == '*' && c1 == '*') + return @':wild-inferiors'; + if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') + return @':up'; + break; + } + default: + if (wild_inferiors) /* '**' surrounded by other characters */ + return @':error'; + } + return make_one(s, j, i); } /* @@ -496,39 +496,39 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start, static cl_object parse_directories(cl_object s, int flags, cl_index start, cl_index end, - cl_index *end_of_dir) + cl_index *end_of_dir) { - cl_index i, j; - cl_object path = ECL_NIL; - delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; + cl_index i, j; + cl_object path = ECL_NIL; + delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; - flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; - *end_of_dir = start; - for (i = j = start; i < end; j = i) { - cl_object part = parse_word(s, delim, flags, j, end, &i); - if (part == @':error' || part == ECL_NIL) - break; - if (part == cl_core.null_string) { /* "/", ";" */ - if (j != start) { - if (flags & WORD_LOGICAL) - return @':error'; - *end_of_dir = i; - continue; - } - part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; - } - *end_of_dir = i; - path = ecl_cons(part, path); - } - return cl_nreverse(path); + flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; + *end_of_dir = start; + for (i = j = start; i < end; j = i) { + cl_object part = parse_word(s, delim, flags, j, end, &i); + if (part == @':error' || part == ECL_NIL) + break; + if (part == cl_core.null_string) { /* "/", ";" */ + if (j != start) { + if (flags & WORD_LOGICAL) + return @':error'; + *end_of_dir = i; + continue; + } + part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; + } + *end_of_dir = i; + path = ecl_cons(part, path); + } + return cl_nreverse(path); } bool ecl_logical_hostname_p(cl_object host) { - if (!ecl_stringp(host)) - return FALSE; - return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); + if (!ecl_stringp(host)) + return FALSE; + return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); } /* @@ -546,296 +546,296 @@ ecl_logical_hostname_p(cl_object host) * tries the physical pathname format. * * 3) Logical pathname syntax: - * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] + * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] * * 4) Physical pathname syntax: - * [device:][[//hostname]/][directory-component/]*[pathname-name][.pathname-type] + * [device:][[//hostname]/][directory-component/]*[pathname-name][.pathname-type] * - * logical-hostname, device, hostname = word - * logical-directory-component = word | wildcard-word - * directory-component = word | wildcard-word | '..' | '.' - * pathname-name, pathname-type = word | wildcard-word | "" + * logical-hostname, device, hostname = word + * logical-directory-component = word | wildcard-word + * directory-component = word | wildcard-word | '..' | '.' + * pathname-name, pathname-type = word | wildcard-word | "" * */ cl_object ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep, - cl_object default_host) + cl_object default_host) { - cl_object host, device, path, name, type, aux, version; - bool logical; + cl_object host, device, path, name, type, aux, version; + bool logical; - if (start == end) { - host = device = path = name = type = aux = version = @'nil'; - logical = 0; - goto make_it; - } - /* We first try parsing as logical-pathname. In case of - * failure, physical-pathname parsing is performed only when - * there is no supplied *logical* host name. All other failures - * result in ECL_NIL as output. - */ - host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | - WORD_DISALLOW_SEMICOLON, start, end, ep); - if (default_host != ECL_NIL) { - if (host == ECL_NIL || host == @':error') - host = default_host; - } - if (!ecl_logical_hostname_p(host)) - goto physical; - /* - * Logical pathname format: - * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] - */ - logical = TRUE; - device = @':unspecific'; - path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':absolute', path); - path = destructively_check_directory(path, TRUE, FALSE); - } else { - path = CONS(@':absolute', path); - } - if (path == @':error') - return ECL_NIL; - name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (name == @':error') - return ECL_NIL; - type = ECL_NIL; - version = ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (aux == @':error') { - return ECL_NIL; - } else if (ECL_SYMBOLP(aux)) { - version = aux; - } else { - const cl_env_ptr the_env = ecl_process_env(); - cl_object parsed_length; - version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); - parsed_length = ecl_nth_value(the_env, 1); - if (ecl_fixnum(parsed_length) == ecl_length(aux) && - cl_integerp(version) != ECL_NIL && ecl_plusp(version)) - ; - else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) - version = @':newest'; - else - return ECL_NIL; - } - goto make_it; + if (start == end) { + host = device = path = name = type = aux = version = @'nil'; + logical = 0; + goto make_it; + } + /* We first try parsing as logical-pathname. In case of + * failure, physical-pathname parsing is performed only when + * there is no supplied *logical* host name. All other failures + * result in ECL_NIL as output. + */ + host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | + WORD_DISALLOW_SEMICOLON, start, end, ep); + if (default_host != ECL_NIL) { + if (host == ECL_NIL || host == @':error') + host = default_host; + } + if (!ecl_logical_hostname_p(host)) + goto physical; + /* + * Logical pathname format: + * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] + */ + logical = TRUE; + device = @':unspecific'; + path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':absolute', path); + path = destructively_check_directory(path, TRUE, FALSE); + } else { + path = CONS(@':absolute', path); + } + if (path == @':error') + return ECL_NIL; + name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (name == @':error') + return ECL_NIL; + type = ECL_NIL; + version = ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (aux == @':error') { + return ECL_NIL; + } else if (ECL_SYMBOLP(aux)) { + version = aux; + } else { + const cl_env_ptr the_env = ecl_process_env(); + cl_object parsed_length; + version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); + parsed_length = ecl_nth_value(the_env, 1); + if (ecl_fixnum(parsed_length) == ecl_length(aux) && + cl_integerp(version) != ECL_NIL && ecl_plusp(version)) + ; + else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) + version = @':newest'; + else + return ECL_NIL; + } + goto make_it; physical: - /* - * Physical pathname format: - * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] - */ - logical = FALSE; - /* We only parse a hostname when the device was present. This - * requisite is a bit stupid and only applies to the Unix port, - * where "//home/" is equivalent to "/home" However, in Windows - * we need "//FOO/" to be separately handled, for it is a shared - * resource. - */ + /* + * Physical pathname format: + * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] + */ + logical = FALSE; + /* We only parse a hostname when the device was present. This + * requisite is a bit stupid and only applies to the Unix port, + * where "//home/" is equivalent to "/home" However, in Windows + * we need "//FOO/" to be separately handled, for it is a shared + * resource. + */ #if defined(ECL_MS_WINDOWS_HOST) - if ((start+1 <= end) && is_slash(ecl_char(s, start))) { - device = ECL_NIL; - goto maybe_parse_host; - } + if ((start+1 <= end) && is_slash(ecl_char(s, start))) { + device = ECL_NIL; + goto maybe_parse_host; + } #endif - device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | - WORD_DISALLOW_SLASH, start, end, ep); - if (device == @':error' || device == ECL_NIL) { - device = ECL_NIL; - host = ECL_NIL; - goto done_device_and_host; - } - if (!ecl_stringp(device)) { - return ECL_NIL; - } + device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | + WORD_DISALLOW_SLASH, start, end, ep); + if (device == @':error' || device == ECL_NIL) { + device = ECL_NIL; + host = ECL_NIL; + goto done_device_and_host; + } + if (!ecl_stringp(device)) { + return ECL_NIL; + } maybe_parse_host: - /* Files have no effective device. */ - if (@string-equal(2, device, @':file') == ECL_T) - device = ECL_NIL; - start = *ep; - host = ECL_NIL; - if ((start+2) <= end && is_slash(ecl_char(s, start)) && - is_slash(ecl_char(s, start+1))) - { - host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, - start+2, end, ep); - if (host == @':error') { - host = ECL_NIL; - } else if (host != ECL_NIL) { - if (!ecl_stringp(host)) - return ECL_NIL; - start = *ep; - if (is_slash(ecl_char(s,--start))) - *ep = start; - } - } - if (ecl_length(device) == 0) - device = ECL_NIL; + /* Files have no effective device. */ + if (@string-equal(2, device, @':file') == ECL_T) + device = ECL_NIL; + start = *ep; + host = ECL_NIL; + if ((start+2) <= end && is_slash(ecl_char(s, start)) && + is_slash(ecl_char(s, start+1))) + { + host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, + start+2, end, ep); + if (host == @':error') { + host = ECL_NIL; + } else if (host != ECL_NIL) { + if (!ecl_stringp(host)) + return ECL_NIL; + start = *ep; + if (is_slash(ecl_char(s,--start))) + *ep = start; + } + } + if (ecl_length(device) == 0) + device = ECL_NIL; done_device_and_host: - path = parse_directories(s, 0, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':relative', path); - path = destructively_check_directory(path, FALSE, FALSE); - } - if (path == @':error') - return ECL_NIL; - start = *ep; - name = parse_word(s, is_dot, - WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | - WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, - start, end, ep); - if (name == @':error') - return ECL_NIL; - if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { - type = ECL_NIL; - } else { - type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - } - version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; + path = parse_directories(s, 0, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':relative', path); + path = destructively_check_directory(path, FALSE, FALSE); + } + if (path == @':error') + return ECL_NIL; + start = *ep; + name = parse_word(s, is_dot, + WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | + WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, + start, end, ep); + if (name == @':error') + return ECL_NIL; + if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { + type = ECL_NIL; + } else { + type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + } + version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; make_it: - if (*ep >= end) *ep = end; - path = ecl_make_pathname(host, device, path, name, type, version, + if (*ep >= end) *ep = end; + path = ecl_make_pathname(host, device, path, name, type, version, @':local'); - path->pathname.logical = logical; - return tilde_expand(path); + path->pathname.logical = logical; + return tilde_expand(path); } cl_object si_default_pathname_defaults(void) { - /* This routine outputs the value of *default-pathname-defaults* - * coerced to type PATHNAME. Special care is taken so that we do - * not enter an infinite loop when using PARSE-NAMESTRING, because - * this routine might itself try to use the value of this variable. */ - cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); - unlikely_if (!ECL_PATHNAMEP(path)) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); + /* This routine outputs the value of *default-pathname-defaults* + * coerced to type PATHNAME. Special care is taken so that we do + * not enter an infinite loop when using PARSE-NAMESTRING, because + * this routine might itself try to use the value of this variable. */ + cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); + unlikely_if (!ECL_PATHNAMEP(path)) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], path, @'pathname'); - } - @(return path) + } + @(return path) } cl_object cl_pathname(cl_object x) { L: - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(1, x); - case t_pathname: - break; - case t_stream: - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_probe: - case ecl_smm_io: - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - x = IO_STREAM_FILENAME(x); - goto L; - case ecl_smm_synonym: - x = SYNONYM_STREAM_STREAM(x); - goto L; - default: - ;/* Fall through to error message */ - } - default: { + case t_base_string: + x = cl_parse_namestring(1, x); + case t_pathname: + break; + case t_stream: + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_probe: + case ecl_smm_io: + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + x = IO_STREAM_FILENAME(x); + goto L; + case ecl_smm_synonym: + x = SYNONYM_STREAM_STREAM(x); + goto L; + default: + ;/* Fall through to error message */ + } + default: { const char *type = "(OR FILE-STREAM STRING PATHNAME)"; FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type)); } - } - @(return x) + } + @(return x) } cl_object cl_logical_pathname(cl_object x) { - x = cl_pathname(x); - if (!x->pathname.logical) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S cannot be coerced to a logical pathname."), - @':format-arguments', cl_list(1, x), - @':expected-type', @'logical-pathname', - @':datum', x); - } - @(return x); + x = cl_pathname(x); + if (!x->pathname.logical) { + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S cannot be coerced to a logical pathname."), + @':format-arguments', cl_list(1, x), + @':expected-type', @'logical-pathname', + @':datum', x); + } + @(return x); } /* FIXME! WILD-PATHNAME-P is missing! */ @(defun wild-pathname-p (pathname &optional component) - bool checked = 0; + bool checked = 0; @ - pathname = cl_pathname(pathname); - if (component == ECL_NIL || component == @':host') { - if (pathname->pathname.host == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':device') { - if (pathname->pathname.device == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':version') { - if (pathname->pathname.version == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':name') { - cl_object name = pathname->pathname.name; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':type') { - cl_object name = pathname->pathname.type; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':directory') { - cl_object list = pathname->pathname.directory; - checked = 1; - loop_for_on_unsafe(list) { - cl_object name = ECL_CONS_CAR(list); - if (name != ECL_NIL && - (name == @':wild' || name == @':wild-inferiors' || - ecl_wild_string_p(name))) - { - @(return ECL_T) - } - } end_loop_for_on_unsafe(list); - } - if (checked == 0) { - FEerror("~A is not a valid pathname component", 1, component); - } - @(return ECL_NIL) + pathname = cl_pathname(pathname); + if (component == ECL_NIL || component == @':host') { + if (pathname->pathname.host == @':wild') + @(return ECL_T); + checked = 1; + } + if (component == ECL_NIL || component == @':device') { + if (pathname->pathname.device == @':wild') + @(return ECL_T); + checked = 1; + } + if (component == ECL_NIL || component == @':version') { + if (pathname->pathname.version == @':wild') + @(return ECL_T); + checked = 1; + } + if (component == ECL_NIL || component == @':name') { + cl_object name = pathname->pathname.name; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) + @(return ECL_T); + checked = 1; + } + if (component == ECL_NIL || component == @':type') { + cl_object name = pathname->pathname.type; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) + @(return ECL_T); + checked = 1; + } + if (component == ECL_NIL || component == @':directory') { + cl_object list = pathname->pathname.directory; + checked = 1; + loop_for_on_unsafe(list) { + cl_object name = ECL_CONS_CAR(list); + if (name != ECL_NIL && + (name == @':wild' || name == @':wild-inferiors' || + ecl_wild_string_p(name))) + { + @(return ECL_T) + } + } end_loop_for_on_unsafe(list); + } + if (checked == 0) { + FEerror("~A is not a valid pathname component", 1, component); + } + @(return ECL_NIL) @) /* @@ -848,22 +848,22 @@ cl_logical_pathname(cl_object x) cl_object coerce_to_file_pathname(cl_object pathname) { - pathname = coerce_to_physical_pathname(pathname); - pathname = cl_merge_pathnames(1, pathname); + pathname = coerce_to_physical_pathname(pathname); + pathname = cl_merge_pathnames(1, pathname); #if 0 #if !defined(cygwin) && !defined(ECL_MS_WINDOWS_HOST) - if (pathname->pathname.device != ECL_NIL) - FEerror("Device ~S not yet supported.", 1, - pathname->pathname.device); - if (pathname->pathname.host != ECL_NIL) - FEerror("Access to remote files not yet supported.", 0); + if (pathname->pathname.device != ECL_NIL) + FEerror("Device ~S not yet supported.", 1, + pathname->pathname.device); + if (pathname->pathname.host != ECL_NIL) + FEerror("Access to remote files not yet supported.", 0); #endif #endif - if (pathname->pathname.directory == ECL_NIL || - ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { - pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); - } - return pathname; + if (pathname->pathname.directory == ECL_NIL || + ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { + pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); + } + return pathname; } /* @@ -873,10 +873,10 @@ coerce_to_file_pathname(cl_object pathname) cl_object coerce_to_physical_pathname(cl_object x) { - x = cl_pathname(x); - if (x->pathname.logical) - return cl_translate_logical_pathname(1, x); - return x; + x = cl_pathname(x); + if (x->pathname.logical) + return cl_translate_logical_pathname(1, x); + return x; } /* @@ -888,35 +888,35 @@ coerce_to_physical_pathname(cl_object x) cl_object si_coerce_to_filename(cl_object pathname_orig) { - cl_object namestring, pathname; + cl_object namestring, pathname; - /* We always go through the pathname representation and thus - * cl_namestring() always outputs a fresh new string */ - pathname = coerce_to_file_pathname(pathname_orig); - if (cl_wild_pathname_p(1,pathname) != ECL_NIL) - cl_error(3, @'file-error', @':pathname', pathname_orig); - namestring = ecl_namestring(pathname, + /* We always go through the pathname representation and thus + * cl_namestring() always outputs a fresh new string */ + pathname = coerce_to_file_pathname(pathname_orig); + if (cl_wild_pathname_p(1,pathname) != ECL_NIL) + cl_error(3, @'file-error', @':pathname', pathname_orig); + namestring = ecl_namestring(pathname, ECL_NAMESTRING_TRUNCATE_IF_ERROR | ECL_NAMESTRING_FORCE_BASE_STRING); - if (namestring == ECL_NIL) { - FEerror("Pathname without a physical namestring:" + if (namestring == ECL_NIL) { + FEerror("Pathname without a physical namestring:" "~% :HOST ~A" "~% :DEVICE ~A" "~% :DIRECTORY ~A" "~% :NAME ~A" "~% :TYPE ~A" "~% :VERSION ~A", - 6, pathname_orig->pathname.host, + 6, pathname_orig->pathname.host, pathname_orig->pathname.device, pathname_orig->pathname.directory, pathname_orig->pathname.name, pathname_orig->pathname.type, pathname_orig->pathname.version); - } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) - FEerror("Too long filename: ~S.", 1, namestring); - return namestring; + } + if (cl_core.path_max != -1 && + ecl_length(namestring) >= cl_core.path_max - 16) + FEerror("Too long filename: ~S.", 1, namestring); + return namestring; } #define default_device(host) ECL_NIL @@ -924,51 +924,51 @@ si_coerce_to_filename(cl_object pathname_orig) cl_object ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) { - cl_object host, device, directory, name, type, version; + cl_object host, device, directory, name, type, version; cl_object tocase; - defaults = cl_pathname(defaults); - path = cl_parse_namestring(1, path, ECL_NIL, defaults); - if (Null(host = path->pathname.host)) - host = defaults->pathname.host; + defaults = cl_pathname(defaults); + path = cl_parse_namestring(1, path, ECL_NIL, defaults); + if (Null(host = path->pathname.host)) + host = defaults->pathname.host; tocase = host_case(host); - if (Null(path->pathname.device)) { - if (Null(path->pathname.host)) - device = cl_pathname_device(3, defaults, @':case', tocase); - else if (path->pathname.host == defaults->pathname.host) - device = defaults->pathname.device; - else - device = default_device(path->pathname.host); - } else { - device = path->pathname.device; + if (Null(path->pathname.device)) { + if (Null(path->pathname.host)) + device = cl_pathname_device(3, defaults, @':case', tocase); + else if (path->pathname.host == defaults->pathname.host) + device = defaults->pathname.device; + else + device = default_device(path->pathname.host); + } else { + device = path->pathname.device; } - if (Null(path->pathname.directory)) { + if (Null(path->pathname.directory)) { directory = cl_pathname_directory(3, defaults, @':case', tocase); } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') { - directory = path->pathname.directory; + directory = path->pathname.directory; } else if (!Null(defaults->pathname.directory)) { - directory = ecl_append(cl_pathname_directory(3, defaults, + directory = ecl_append(cl_pathname_directory(3, defaults, @':case', tocase), CDR(path->pathname.directory)); /* Eliminate redundant :back */ directory = destructively_check_directory(directory, TRUE, TRUE); } else { - directory = path->pathname.directory; + directory = path->pathname.directory; } - if (Null(name = path->pathname.name)) { - name = cl_pathname_name(3, defaults, @':case', tocase); + if (Null(name = path->pathname.name)) { + name = cl_pathname_name(3, defaults, @':case', tocase); } - if (Null(type = path->pathname.type)) { - type = cl_pathname_type(3, defaults, @':case', tocase); + if (Null(type = path->pathname.type)) { + type = cl_pathname_type(3, defaults, @':case', tocase); + } + version = path->pathname.version; + if (Null(path->pathname.name)) { + if (Null(version)) + version = defaults->pathname.version; + } + if (Null(version)) { + version = default_version; } - version = path->pathname.version; - if (Null(path->pathname.name)) { - if (Null(version)) - version = defaults->pathname.version; - } - if (Null(version)) { - version = default_version; - } if (default_version == @':default') { if (Null(name) && Null(type)) { version = ECL_NIL; @@ -976,283 +976,283 @@ ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_versio version = @':newest'; } } - /* - In this implementation, version is not considered - */ - defaults = ecl_make_pathname(host, device, directory, name, + /* + In this implementation, version is not considered + */ + defaults = ecl_make_pathname(host, device, directory, name, type, version, tocase); - return defaults; + return defaults; } /* - ecl_namestring(x, flag) converts a pathname to a namestring. - if flag is true, then the pathname may be coerced to the requirements - of the filesystem, removing fields that have no meaning (such as - version, or type, etc); otherwise, when it is not possible to - produce a readable representation of the pathname, NIL is returned. + ecl_namestring(x, flag) converts a pathname to a namestring. + if flag is true, then the pathname may be coerced to the requirements + of the filesystem, removing fields that have no meaning (such as + version, or type, etc); otherwise, when it is not possible to + produce a readable representation of the pathname, NIL is returned. */ cl_object ecl_namestring(cl_object x, int flags) { - bool logical; - cl_object l, y; - cl_object buffer, host; + bool logical; + cl_object l, y; + cl_object buffer, host; bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR; - x = cl_pathname(x); + x = cl_pathname(x); - /* INV: Pathnames can only be created by mergin, parsing namestrings - * or using ecl_make_pathname(). In all of these cases ECL will complain - * at creation time if the pathname has wrong components. - */ - buffer = ecl_make_string_output_stream(128, 1); - logical = x->pathname.logical; - host = x->pathname.host; - if (logical) { - if ((y = x->pathname.device) != @':unspecific' && - truncate_if_unreadable) - return ECL_NIL; - if (host != ECL_NIL) { - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - } else { - if ((y = x->pathname.device) != ECL_NIL) { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - if (host != ECL_NIL) { + /* INV: Pathnames can only be created by mergin, parsing namestrings + * or using ecl_make_pathname(). In all of these cases ECL will complain + * at creation time if the pathname has wrong components. + */ + buffer = ecl_make_string_output_stream(128, 1); + logical = x->pathname.logical; + host = x->pathname.host; + if (logical) { + if ((y = x->pathname.device) != @':unspecific' && + truncate_if_unreadable) + return ECL_NIL; + if (host != ECL_NIL) { + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + } else { + if ((y = x->pathname.device) != ECL_NIL) { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + if (host != ECL_NIL) { #if !defined(ECL_MS_WINDOWS_HOST) - if (y == ECL_NIL) { - writestr_stream("file:", buffer); - } + if (y == ECL_NIL) { + writestr_stream("file:", buffer); + } #endif - writestr_stream("//", buffer); - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } - l = x->pathname.directory; - if (ecl_endp(l)) - goto NO_DIRECTORY; - y = ECL_CONS_CAR(l); - if (y == @':relative') { - if (logical) - ecl_write_char(';', buffer); - } else { - if (!logical) - ecl_write_char(DIR_SEPARATOR, buffer); - } - l = ECL_CONS_CDR(l); - loop_for_in(l) { - y = ECL_CONS_CAR(l); - if (y == @':up') { - writestr_stream("..", buffer); - } else if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':wild-inferiors') { - writestr_stream("**", buffer); - } else if (y != @':back') { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } else { - /* Directory :back has no namestring representation */ - return ECL_NIL; - } - ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); - } end_loop_for_in; + writestr_stream("//", buffer); + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + l = x->pathname.directory; + if (ecl_endp(l)) + goto NO_DIRECTORY; + y = ECL_CONS_CAR(l); + if (y == @':relative') { + if (logical) + ecl_write_char(';', buffer); + } else { + if (!logical) + ecl_write_char(DIR_SEPARATOR, buffer); + } + l = ECL_CONS_CDR(l); + loop_for_in(l) { + y = ECL_CONS_CAR(l); + if (y == @':up') { + writestr_stream("..", buffer); + } else if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':wild-inferiors') { + writestr_stream("**", buffer); + } else if (y != @':back') { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } else { + /* Directory :back has no namestring representation */ + return ECL_NIL; + } + ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); + } end_loop_for_in; NO_DIRECTORY: - if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { - if ((ecl_stringp(x->pathname.name) && - ecl_member_char(':', x->pathname.name)) || - (ecl_stringp(x->pathname.type) && - ecl_member_char(':', x->pathname.type))) - writestr_stream(":", buffer); - } - y = x->pathname.name; - if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream("*", buffer); - } else { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } else if (!logical && !Null(x->pathname.type)) { + if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { + if ((ecl_stringp(x->pathname.name) && + ecl_member_char(':', x->pathname.name)) || + (ecl_stringp(x->pathname.type) && + ecl_member_char(':', x->pathname.type))) + writestr_stream(":", buffer); + } + y = x->pathname.name; + if (y != ECL_NIL) { + if (y == @':wild') { + writestr_stream("*", buffer); + } else { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } else if (!logical && !Null(x->pathname.type)) { /* #P".txt" is :NAME = ".txt" :TYPE = NIL and hence :NAME = NIL and :TYPE != NIL does not have a printed representation */ return ECL_NIL; } - y = x->pathname.type; + y = x->pathname.type; if (y == @':unspecific') { return ECL_NIL; } else if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream(".*", buffer); - } else { - writestr_stream(".", buffer); - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } - y = x->pathname.version; - if (logical) { - if (y != ECL_NIL) { - writestr_stream(".", buffer); - if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':newest') { - si_do_write_sequence(ecl_symbol_name(y), buffer, - ecl_make_fixnum(0), ECL_NIL); - } else { - /* Since the printer is not reentrant, - * we cannot use cl_write and friends. - */ - int n = ecl_fixnum(y), i; - char b[FIXNUM_BITS/2]; - for (i = 0; n; i++) { - b[i] = n%10 + '0'; - n = n/10; - } - if (i == 0) - b[i++] = '0'; - while (i--) { - ecl_write_char(b[i], buffer); - } - } - } - } else if (!truncate_if_unreadable) { - /* Namestrings of physical pathnames have restrictions... */ - if (Null(x->pathname.name) && Null(x->pathname.type)) { - /* Directories cannot have a version number */ - if (y != ECL_NIL) - return ECL_NIL; - } else if (y != @':newest') { - /* Filenames have an implicit version :newest */ - return ECL_NIL; - } - } + if (y == @':wild') { + writestr_stream(".*", buffer); + } else { + writestr_stream(".", buffer); + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + y = x->pathname.version; + if (logical) { + if (y != ECL_NIL) { + writestr_stream(".", buffer); + if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':newest') { + si_do_write_sequence(ecl_symbol_name(y), buffer, + ecl_make_fixnum(0), ECL_NIL); + } else { + /* Since the printer is not reentrant, + * we cannot use cl_write and friends. + */ + int n = ecl_fixnum(y), i; + char b[FIXNUM_BITS/2]; + for (i = 0; n; i++) { + b[i] = n%10 + '0'; + n = n/10; + } + if (i == 0) + b[i++] = '0'; + while (i--) { + ecl_write_char(b[i], buffer); + } + } + } + } else if (!truncate_if_unreadable) { + /* Namestrings of physical pathnames have restrictions... */ + if (Null(x->pathname.name) && Null(x->pathname.type)) { + /* Directories cannot have a version number */ + if (y != ECL_NIL) + return ECL_NIL; + } else if (y != @':newest') { + /* Filenames have an implicit version :newest */ + return ECL_NIL; + } + } buffer = cl_get_output_stream_string(buffer); #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(buffer) && + if (ECL_EXTENDED_STRING_P(buffer) && (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) { - unlikely_if (!ecl_fits_in_base_string(buffer)) - FEerror("The filesystem does not accept filenames " + unlikely_if (!ecl_fits_in_base_string(buffer)) + FEerror("The filesystem does not accept filenames " "with extended characters: ~S", - 1, buffer); - buffer = si_copy_to_simple_base_string(buffer); - } + 1, buffer); + buffer = si_copy_to_simple_base_string(buffer); + } #endif - return buffer; + return buffer; } cl_object cl_namestring(cl_object x) { - @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) } @(defun parse_namestring (thing - &o host (defaults si_default_pathname_defaults()) - &k (start ecl_make_fixnum(0)) end junk_allowed - &a output) + &o host (defaults si_default_pathname_defaults()) + &k (start ecl_make_fixnum(0)) end junk_allowed + &a output) @ - if (host != ECL_NIL) { - host = cl_string(host); - } - if (!ecl_stringp(thing)) { - output = cl_pathname(thing); - } else { - cl_object default_host = host; + if (host != ECL_NIL) { + host = cl_string(host); + } + if (!ecl_stringp(thing)) { + output = cl_pathname(thing); + } else { + cl_object default_host = host; cl_index_pair p; cl_index ee; - if (default_host == ECL_NIL && defaults != ECL_NIL) { - defaults = cl_pathname(defaults); - default_host = defaults->pathname.host; - } - p = ecl_vector_start_end(@[parse-namestring], thing, start, end); - output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); - start = ecl_make_fixnum(ee); - if (output == ECL_NIL || ee != p.end) { - if (Null(junk_allowed)) { - FEparse_error("Cannot parse the namestring ~S~%" - "from ~S to ~S.", ECL_NIL, - 3, thing, start, end); - } - goto OUTPUT; - } - } - if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { - FEerror("The pathname ~S does not contain the required host ~S.", - 2, thing, host); - } + if (default_host == ECL_NIL && defaults != ECL_NIL) { + defaults = cl_pathname(defaults); + default_host = defaults->pathname.host; + } + p = ecl_vector_start_end(@[parse-namestring], thing, start, end); + output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); + start = ecl_make_fixnum(ee); + if (output == ECL_NIL || ee != p.end) { + if (Null(junk_allowed)) { + FEparse_error("Cannot parse the namestring ~S~%" + "from ~S to ~S.", ECL_NIL, + 3, thing, start, end); + } + goto OUTPUT; + } + } + if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { + FEerror("The pathname ~S does not contain the required host ~S.", + 2, thing, host); + } OUTPUT: - @(return output start) + @(return output start) @) @(defun merge_pathnames (path - &o (defaults si_default_pathname_defaults()) - (default_version @':newest')) + &o (defaults si_default_pathname_defaults()) + (default_version @':newest')) @ - path = cl_pathname(path); - defaults = cl_pathname(defaults); - @(return ecl_merge_pathnames(path, defaults, default_version)) + path = cl_pathname(path); + defaults = cl_pathname(defaults); + @(return ecl_merge_pathnames(path, defaults, default_version)) @) @(defun make_pathname (&key (host ECL_NIL hostp) (device ECL_NIL devicep) - (directory ECL_NIL directoryp) - (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) - ((:case scase) @':local') - defaults - &aux x) + (directory ECL_NIL directoryp) + (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) + ((:case scase) @':local') + defaults + &aux x) @ - if (Null(defaults)) { - defaults = si_default_pathname_defaults(); - defaults = ecl_make_pathname(defaults->pathname.host, - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, + if (Null(defaults)) { + defaults = si_default_pathname_defaults(); + defaults = ecl_make_pathname(defaults->pathname.host, + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, @':local'); - } else { - defaults = cl_pathname(defaults); - } - if (!hostp) host = defaults->pathname.host; - x = ecl_make_pathname(host, device, directory, name, type, version, scase); - if (!devicep) x->pathname.device = defaults->pathname.device; - if (!directoryp) x->pathname.directory = defaults->pathname.directory; - if (!namep) x->pathname.name = defaults->pathname.name; - if (!typep) x->pathname.type = defaults->pathname.type; - if (!versionp) x->pathname.version = defaults->pathname.version; + } else { + defaults = cl_pathname(defaults); + } + if (!hostp) host = defaults->pathname.host; + x = ecl_make_pathname(host, device, directory, name, type, version, scase); + if (!devicep) x->pathname.device = defaults->pathname.device; + if (!directoryp) x->pathname.directory = defaults->pathname.directory; + if (!namep) x->pathname.name = defaults->pathname.name; + if (!typep) x->pathname.type = defaults->pathname.type; + if (!versionp) x->pathname.version = defaults->pathname.version; - @(return x) + @(return x) @) cl_object cl_pathnamep(cl_object pname) { - @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)) + @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)) } cl_object si_logical_pathname_p(cl_object pname) { - @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? - ECL_T : ECL_NIL)) + @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? + ECL_T : ECL_NIL)) } @(defun pathname_host (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.host, + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.host, normalize_case(pname, @':local'), normalize_case(pname, scase))) @) @(defun pathname_device (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.device, + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.device, normalize_case(pname, @':local'), normalize_case(pname, scase))) @) @(defun pathname_directory (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); + pname = cl_pathname(pname); @(return translate_list_case(pname->pathname.directory, normalize_case(pname, @':local'), normalize_case(pname, scase))) @@ -1260,15 +1260,15 @@ si_logical_pathname_p(cl_object pname) @(defun pathname_name(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.name, + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.name, normalize_case(pname, @':local'), normalize_case(pname, scase))) @) @(defun pathname_type(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); + pname = cl_pathname(pname); @(return translate_component_case(pname->pathname.type, normalize_case(pname, @':local'), normalize_case(pname, scase))) @@ -1277,84 +1277,84 @@ si_logical_pathname_p(cl_object pname) cl_object cl_pathname_version(cl_object pname) { - pname = cl_pathname(pname); - @(return pname->pathname.version) + pname = cl_pathname(pname); + @(return pname->pathname.version) } cl_object cl_file_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, - pname->pathname.name, - pname->pathname.type, - pname->pathname.version, + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + pname->pathname.name, + pname->pathname.type, + pname->pathname.version, @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + ECL_NAMESTRING_TRUNCATE_IF_ERROR)) } cl_object cl_directory_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, - pname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, + pname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + ECL_NAMESTRING_TRUNCATE_IF_ERROR)) } cl_object cl_host_namestring(cl_object pname) { - pname = cl_pathname(pname); - pname = pname->pathname.host; - if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; - @(return pname) + pname = cl_pathname(pname); + pname = pname->pathname.host; + if (Null(pname) || pname == @':wild') + pname = cl_core.null_string; + @(return pname) } #define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? ECL_NIL : p1->pathname.el) @(defun enough_namestring (path - &o (defaults si_default_pathname_defaults())) - cl_object newpath, pathdir, defaultdir, fname; + &o (defaults si_default_pathname_defaults())) + cl_object newpath, pathdir, defaultdir, fname; @ - defaults = cl_pathname(defaults); - path = cl_pathname(path); - pathdir = path->pathname.directory; - defaultdir = defaults->pathname.directory; - if (Null(pathdir)) { - pathdir = ecl_list1(@':relative'); - } else if (Null(defaultdir)) { - /* The defaults pathname does not have a directory. */ - } else if (ECL_CONS_CAR(pathdir) == @':relative') { - /* The pathname is relative to the default one one, so we just output the - original one */ - } else { - /* The new pathname is an absolute one. We compare it with the defaults - and if they have some common elements, we just output the remaining ones. */ - cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, - @':test', @'equal'); - if (dir_begin == ECL_NIL) { - pathdir = ECL_NIL; - } else if (dir_begin == cl_length(defaultdir)) { - pathdir = funcall(3, @'subseq', pathdir, dir_begin); - pathdir = CONS(@':relative', pathdir); - } - } - fname = EN_MATCH(path, defaults, name); - if (fname == ECL_NIL) fname = path->pathname.name; - /* Create a path with all elements that do not match the default */ - newpath - = ecl_make_pathname(EN_MATCH(path, defaults, host), - EN_MATCH(path, defaults, device), - pathdir, fname, - EN_MATCH(path, defaults, type), - EN_MATCH(path, defaults, version), + defaults = cl_pathname(defaults); + path = cl_pathname(path); + pathdir = path->pathname.directory; + defaultdir = defaults->pathname.directory; + if (Null(pathdir)) { + pathdir = ecl_list1(@':relative'); + } else if (Null(defaultdir)) { + /* The defaults pathname does not have a directory. */ + } else if (ECL_CONS_CAR(pathdir) == @':relative') { + /* The pathname is relative to the default one one, so we just output the + original one */ + } else { + /* The new pathname is an absolute one. We compare it with the defaults + and if they have some common elements, we just output the remaining ones. */ + cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, + @':test', @'equal'); + if (dir_begin == ECL_NIL) { + pathdir = ECL_NIL; + } else if (dir_begin == cl_length(defaultdir)) { + pathdir = funcall(3, @'subseq', pathdir, dir_begin); + pathdir = CONS(@':relative', pathdir); + } + } + fname = EN_MATCH(path, defaults, name); + if (fname == ECL_NIL) fname = path->pathname.name; + /* Create a path with all elements that do not match the default */ + newpath + = ecl_make_pathname(EN_MATCH(path, defaults, host), + EN_MATCH(path, defaults, device), + pathdir, fname, + EN_MATCH(path, defaults, type), + EN_MATCH(path, defaults, version), @':local'); - newpath->pathname.logical = path->pathname.logical; - @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + newpath->pathname.logical = path->pathname.logical; + @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) @) #undef EN_MATCH @@ -1363,15 +1363,15 @@ cl_host_namestring(cl_object pname) bool ecl_wild_string_p(cl_object item) { - if (ECL_STRINGP(item)) { - cl_index i, l = ecl_length(item); - for (i = 0; i < l; i++) { - ecl_character c = ecl_char(item, i); - if (c == '\\' || c == '*' || c == '?') - return 1; - } - } - return 0; + if (ECL_STRINGP(item)) { + cl_index i, l = ecl_length(item); + for (i = 0; i < l; i++) { + ecl_character c = ecl_char(item, i); + if (c == '\\' || c == '*' || c == '?') + return 1; + } + } + return 0; } /* @@ -1383,30 +1383,30 @@ bool ecl_string_match(cl_object s, cl_index j, cl_index ls, cl_object p, cl_index i, cl_index lp) { - while (i < lp) { - cl_index cp = ecl_char(p, i); + while (i < lp) { + cl_index cp = ecl_char(p, i); switch (cp) { case '*': { - /* An asterisk in the pattern matches any - * number of characters. We try the shortest - * sequence that matches. */ - cl_index cn = 0, next; - for (next = i+1; - next < lp && ((cn = ecl_char(p, next)) == '*'); - next++) - ; - if (next == lp) { - return TRUE; - } - while (j < ls) { - if (ecl_string_match(s, j, ls, p, next, lp)) { - return TRUE; - } - j++; - } - return FALSE; + /* An asterisk in the pattern matches any + * number of characters. We try the shortest + * sequence that matches. */ + cl_index cn = 0, next; + for (next = i+1; + next < lp && ((cn = ecl_char(p, next)) == '*'); + next++) + ; + if (next == lp) { + return TRUE; + } + while (j < ls) { + if (ecl_string_match(s, j, ls, p, next, lp)) { + return TRUE; + } + j++; + } + return FALSE; break; - } + } case '?': /* Match any character */ if (j > ls) return FALSE; @@ -1424,82 +1424,82 @@ ecl_string_match(cl_object s, cl_index j, cl_index ls, } i++; j++; } - } + } /* At the end all characters should have been matched */ - return (j >= ls); + return (j >= ls); } static bool path_item_match(cl_object a, cl_object mask) { - if (mask == @':wild') - return TRUE; - /* If a component in the tested path is a wildcard field, this - can only be matched by the same wildcard field in the mask */ - if (!ecl_stringp(a) || mask == ECL_NIL) - return (a == mask); - if (!ecl_stringp(mask)) - FEerror("~S is not supported as mask for pathname-match-p", 1, mask); - return ecl_string_match(a, 0, ecl_length(a), + if (mask == @':wild') + return TRUE; + /* If a component in the tested path is a wildcard field, this + can only be matched by the same wildcard field in the mask */ + if (!ecl_stringp(a) || mask == ECL_NIL) + return (a == mask); + if (!ecl_stringp(mask)) + FEerror("~S is not supported as mask for pathname-match-p", 1, mask); + return ecl_string_match(a, 0, ecl_length(a), mask, 0, ecl_length(mask)); } static bool path_list_match(cl_object a, cl_object mask) { - cl_object item_mask; - while (!ecl_endp(mask)) { - item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - if (ecl_endp(mask)) - return TRUE; - while (!ecl_endp(a)) { - if (path_list_match(a, mask)) - return TRUE; - a = CDR(a); - } - return FALSE; - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return FALSE; - } else if (!path_item_match(CAR(a), item_mask)) { - return FALSE; - } else { - a = CDR(a); - } - } - if (!ecl_endp(a)) - return FALSE; - return TRUE; + cl_object item_mask; + while (!ecl_endp(mask)) { + item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + if (ecl_endp(mask)) + return TRUE; + while (!ecl_endp(a)) { + if (path_list_match(a, mask)) + return TRUE; + a = CDR(a); + } + return FALSE; + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return FALSE; + } else if (!path_item_match(CAR(a), item_mask)) { + return FALSE; + } else { + a = CDR(a); + } + } + if (!ecl_endp(a)) + return FALSE; + return TRUE; } cl_object cl_pathname_match_p(cl_object path, cl_object mask) { - cl_object output = ECL_NIL; - path = cl_pathname(path); - mask = cl_pathname(mask); - if (path->pathname.logical != mask->pathname.logical) - goto OUTPUT; + cl_object output = ECL_NIL; + path = cl_pathname(path); + mask = cl_pathname(mask); + if (path->pathname.logical != mask->pathname.logical) + goto OUTPUT; #if 0 - /* INV: This was checked in the calling routine */ - if (!path_item_match(path->pathname.host, mask->pathname.host)) - goto OUTPUT; + /* INV: This was checked in the calling routine */ + if (!path_item_match(path->pathname.host, mask->pathname.host)) + goto OUTPUT; #endif - /* Missing components default to :WILD */ - if (!Null(mask->pathname.directory) && - !path_list_match(path->pathname.directory, mask->pathname.directory)) - goto OUTPUT; - if (!path_item_match(path->pathname.name, mask->pathname.name)) - goto OUTPUT; - if (!path_item_match(path->pathname.type, mask->pathname.type)) - goto OUTPUT; - if (Null(mask->pathname.version) || - path_item_match(path->pathname.version, mask->pathname.version)) - output = ECL_T; + /* Missing components default to :WILD */ + if (!Null(mask->pathname.directory) && + !path_list_match(path->pathname.directory, mask->pathname.directory)) + goto OUTPUT; + if (!path_item_match(path->pathname.name, mask->pathname.name)) + goto OUTPUT; + if (!path_item_match(path->pathname.type, mask->pathname.type)) + goto OUTPUT; + if (Null(mask->pathname.version) || + path_item_match(path->pathname.version, mask->pathname.version)) + output = ECL_T; OUTPUT: - @(return output) + @(return output) } /* --------------- PATHNAME TRANSLATIONS ------------------ */ @@ -1507,235 +1507,235 @@ cl_pathname_match_p(cl_object path, cl_object mask) static cl_object coerce_to_from_pathname(cl_object x, cl_object host) { - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(2, x, host); - case t_pathname: - if (x->pathname.logical) - return x; - default: - FEerror("~S is not a valid from-pathname translation", 1, x); - } + case t_base_string: + x = cl_parse_namestring(2, x, host); + case t_pathname: + if (x->pathname.logical) + return x; + default: + FEerror("~S is not a valid from-pathname translation", 1, x); + } } @(defun si::pathname-translations (host &optional (set OBJNULL)) - cl_index parsed_len, len; - cl_object pair, l; + cl_index parsed_len, len; + cl_object pair, l; @ - /* Check that host is a valid host name */ + /* Check that host is a valid host name */ if (ecl_unlikely(!ECL_STRINGP(host))) FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]); - host = cl_string_upcase(1, host); - len = ecl_length(host); - parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); - if (parsed_len < len) { - FEerror("Wrong host syntax ~S", 1, host); - } - /* Find its translation list */ - pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); - if (set == OBJNULL) { - @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); - } - /* Set the new translation list */ + host = cl_string_upcase(1, host); + len = ecl_length(host); + parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); + if (parsed_len < len) { + FEerror("Wrong host syntax ~S", 1, host); + } + /* Find its translation list */ + pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); + if (set == OBJNULL) { + @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); + } + /* Set the new translation list */ if (ecl_unlikely(!LISTP(set))) { FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]); } - if (pair == ECL_NIL) { - pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); - } - for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { - cl_object item = CAR(l); - cl_object from = coerce_to_from_pathname(cl_car(item), host); - cl_object to = cl_pathname(cl_cadr(item)); - set = CONS(CONS(from, CONS(to, ECL_NIL)), set); - } - set = cl_nreverse(set); - ECL_RPLACA(ECL_CONS_CDR(pair), set); - @(return set) + if (pair == ECL_NIL) { + pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); + cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + } + for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { + cl_object item = CAR(l); + cl_object from = coerce_to_from_pathname(cl_car(item), host); + cl_object to = cl_pathname(cl_cadr(item)); + set = CONS(CONS(from, CONS(to, ECL_NIL)), set); + } + set = cl_nreverse(set); + ECL_RPLACA(ECL_CONS_CDR(pair), set); + @(return set) @) static cl_object find_wilds(cl_object l, cl_object source, cl_object match) { - cl_index i, j, k, ls, lm; + cl_index i, j, k, ls, lm; - if (match == @':wild') - return ecl_list1(source); - if (!ecl_stringp(match) || !ecl_stringp(source)) { - if (match != source) - return @':error'; - return l; - } - ls = ecl_length(source); - lm = ecl_length(match); - for(i = j = 0; i < ls && j < lm; ) { - cl_index pattern_char = ecl_char(match,j); - if (pattern_char == '*') { - for (j++, k = i; - k < ls && ecl_char(source,k) != pattern_char; - k++) - ; - l = CONS(make_one(source, i, k), l); - i = k; - continue; - } - if (ecl_char(source,i) != pattern_char) - return @':error'; - i++, j++; - } - if (i < ls || j < lm) - return @':error'; - return l; + if (match == @':wild') + return ecl_list1(source); + if (!ecl_stringp(match) || !ecl_stringp(source)) { + if (match != source) + return @':error'; + return l; + } + ls = ecl_length(source); + lm = ecl_length(match); + for(i = j = 0; i < ls && j < lm; ) { + cl_index pattern_char = ecl_char(match,j); + if (pattern_char == '*') { + for (j++, k = i; + k < ls && ecl_char(source,k) != pattern_char; + k++) + ; + l = CONS(make_one(source, i, k), l); + i = k; + continue; + } + if (ecl_char(source,i) != pattern_char) + return @':error'; + i++, j++; + } + if (i < ls || j < lm) + return @':error'; + return l; } static cl_object find_list_wilds(cl_object a, cl_object mask) { - cl_object l = ECL_NIL, l2; + cl_object l = ECL_NIL, l2; - while (!ecl_endp(mask)) { - cl_object item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - l2 = ECL_NIL; - while (!path_list_match(a, mask)) { - if (ecl_endp(a)) - return @':error'; - l2 = CONS(CAR(a),l2); - a = CDR(a); - } - l = CONS(l2, l); - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return @':error'; - } else { - l2 = find_wilds(l, CAR(a), item_mask); - if (l == @':error') - return @':error'; - if (!Null(l2)) - l = CONS(l2, l); - a = CDR(a); - } - } - return @nreverse(l); + while (!ecl_endp(mask)) { + cl_object item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + l2 = ECL_NIL; + while (!path_list_match(a, mask)) { + if (ecl_endp(a)) + return @':error'; + l2 = CONS(CAR(a),l2); + a = CDR(a); + } + l = CONS(l2, l); + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return @':error'; + } else { + l2 = find_wilds(l, CAR(a), item_mask); + if (l == @':error') + return @':error'; + if (!Null(l2)) + l = CONS(l2, l); + a = CDR(a); + } + } + return @nreverse(l); } static cl_object copy_wildcards(cl_object *wilds_list, cl_object pattern) { - cl_index i, l, j; - bool new_string; - cl_object wilds = *wilds_list, token; + cl_index i, l, j; + bool new_string; + cl_object wilds = *wilds_list, token; - if (pattern == @':wild') { - if (ecl_endp(wilds)) - return @':error'; - pattern = CAR(wilds); - *wilds_list = CDR(wilds); - return pattern; - } - if (pattern == @':wild-inferiors') - return @':error'; - if (!ecl_stringp(pattern)) - return pattern; + if (pattern == @':wild') { + if (ecl_endp(wilds)) + return @':error'; + pattern = CAR(wilds); + *wilds_list = CDR(wilds); + return pattern; + } + if (pattern == @':wild-inferiors') + return @':error'; + if (!ecl_stringp(pattern)) + return pattern; - new_string = FALSE; - l = ecl_length(pattern); - token = si_get_buffer_string(); - for (j = i = 0; i < l; ) { - cl_index c = ecl_char(pattern, i); - if (c != '*') { - i++; - continue; - } - if (i != j) { - push_substring(token, pattern, j, i); - } - new_string = TRUE; - if (ecl_endp(wilds)) { - return @':error'; - } - push_string(token, CAR(wilds)); - wilds = CDR(wilds); - j = i++; - } - /* Only create a new string when needed */ - if (new_string) { - pattern = cl_copy_seq(token); - } - si_put_buffer_string(token); - *wilds_list = wilds; - return pattern; + new_string = FALSE; + l = ecl_length(pattern); + token = si_get_buffer_string(); + for (j = i = 0; i < l; ) { + cl_index c = ecl_char(pattern, i); + if (c != '*') { + i++; + continue; + } + if (i != j) { + push_substring(token, pattern, j, i); + } + new_string = TRUE; + if (ecl_endp(wilds)) { + return @':error'; + } + push_string(token, CAR(wilds)); + wilds = CDR(wilds); + j = i++; + } + /* Only create a new string when needed */ + if (new_string) { + pattern = cl_copy_seq(token); + } + si_put_buffer_string(token); + *wilds_list = wilds; + return pattern; } static cl_object copy_list_wildcards(cl_object *wilds, cl_object to) { - cl_object l = ECL_NIL; + cl_object l = ECL_NIL; - while (!ecl_endp(to)) { - cl_object d, mask = CAR(to); - if (mask == @':wild-inferiors') { - cl_object list = *wilds; - if (ecl_endp(list)) - return @':error'; - else { - cl_object dirlist = CAR(list); - if (CONSP(dirlist)) - l = ecl_append(CAR(list), l); - else if (!Null(CAR(list))) - return @':error'; - } - *wilds = CDR(list); - } else { - d = copy_wildcards(wilds, CAR(to)); - if (d == @':error') - return d; - l = CONS(d, l); - } - to = CDR(to); - } - if (CONSP(l)) - l = @nreverse(l); - return l; + while (!ecl_endp(to)) { + cl_object d, mask = CAR(to); + if (mask == @':wild-inferiors') { + cl_object list = *wilds; + if (ecl_endp(list)) + return @':error'; + else { + cl_object dirlist = CAR(list); + if (CONSP(dirlist)) + l = ecl_append(CAR(list), l); + else if (!Null(CAR(list))) + return @':error'; + } + *wilds = CDR(list); + } else { + d = copy_wildcards(wilds, CAR(to)); + if (d == @':error') + return d; + l = CONS(d, l); + } + to = CDR(to); + } + if (CONSP(l)) + l = @nreverse(l); + return l; } @(defun translate-pathname (source from to &key ((:case scase) @':local')) - cl_object wilds, d; - cl_object host, device, directory, name, type, version; - cl_object fromcase, tocase; + cl_object wilds, d; + cl_object host, device, directory, name, type, version; + cl_object fromcase, tocase; @ - /* The pathname from which we get the data */ - source = cl_pathname(source); - /* The mask applied to the source pathname */ - from = cl_pathname(from); - fromcase = normalize_case(from, @':local'); - /* The pattern which says what the output should look like */ - to = cl_pathname(to); - tocase = normalize_case(to, @':local'); + /* The pathname from which we get the data */ + source = cl_pathname(source); + /* The mask applied to the source pathname */ + from = cl_pathname(from); + fromcase = normalize_case(from, @':local'); + /* The pattern which says what the output should look like */ + to = cl_pathname(to); + tocase = normalize_case(to, @':local'); - if (source->pathname.logical != from->pathname.logical) - goto error; + if (source->pathname.logical != from->pathname.logical) + goto error; - /* Match host names */ - if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) - goto error; - host = to->pathname.host; + /* Match host names */ + if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) + goto error; + host = to->pathname.host; - /* Logical pathnames do not have devices. We just overwrite it. */ - device = to->pathname.device; + /* Logical pathnames do not have devices. We just overwrite it. */ + device = to->pathname.device; - /* Match directories */ - wilds = find_list_wilds(source->pathname.directory, - from->pathname.directory); - if (wilds == @':error') goto error; - if (Null(to->pathname.directory)) { + /* Match directories */ + wilds = find_list_wilds(source->pathname.directory, + from->pathname.directory); + if (wilds == @':error') goto error; + if (Null(to->pathname.directory)) { /* Missing components are replaced */ d = translate_list_case(from->pathname.directory, fromcase, tocase); } else { @@ -1744,12 +1744,12 @@ copy_list_wildcards(cl_object *wilds, cl_object to) if (d == @':error') goto error; if (wilds != ECL_NIL) goto error2; } - directory = d; + directory = d; - /* Match name */ - wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); - if (wilds == @':error') goto error2; - if (Null(to->pathname.name)) { + /* Match name */ + wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); + if (wilds == @':error') goto error2; + if (Null(to->pathname.name)) { d = translate_component_case(from->pathname.name, fromcase, tocase); } else { wilds = translate_list_case(wilds, fromcase, tocase); @@ -1757,12 +1757,12 @@ copy_list_wildcards(cl_object *wilds, cl_object to) if (d == @':error') goto error; if (wilds != ECL_NIL) goto error2; } - name = d; + name = d; - /* Match type */ - wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); - if (wilds == @':error') goto error2; - if (Null(to->pathname.type)) { + /* Match type */ + wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); + if (wilds == @':error') goto error2; + if (Null(to->pathname.type)) { d = translate_component_case(from->pathname.type, fromcase, tocase); } else { wilds = translate_list_case(wilds, fromcase, tocase); @@ -1770,41 +1770,41 @@ copy_list_wildcards(cl_object *wilds, cl_object to) if (d == @':error') goto error; if (wilds != ECL_NIL) goto error2; } - type = d; + type = d; - /* Match version */ - version = to->pathname.version; - if (from->pathname.version == @':wild') { - if (to->pathname.version == @':wild') { - version = source->pathname.version; - } - } - @(return ecl_make_pathname(host, device, directory, name, type, - version, tocase)); + /* Match version */ + version = to->pathname.version; + if (from->pathname.version == @':wild') { + if (to->pathname.version == @':wild') { + version = source->pathname.version; + } + } + @(return ecl_make_pathname(host, device, directory, name, type, + version, tocase)); error: - FEerror("~S is not a specialization of path ~S", 2, source, from); + FEerror("~S is not a specialization of path ~S", 2, source, from); error2: - FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); + FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); @) @(defun translate-logical-pathname (source &key) - cl_object l, pair; - cl_object pathname; + cl_object l, pair; + cl_object pathname; @ - pathname = cl_pathname(source); + pathname = cl_pathname(source); begin: - if (!pathname->pathname.logical) { - @(return pathname) - } - l = @si::pathname-translations(1, pathname->pathname.host); - for(; !ecl_endp(l); l = CDR(l)) { - pair = CAR(l); - if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { - pathname = cl_translate_pathname(3, pathname, + if (!pathname->pathname.logical) { + @(return pathname) + } + l = @si::pathname-translations(1, pathname->pathname.host); + for(; !ecl_endp(l); l = CDR(l)) { + pair = CAR(l); + if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { + pathname = cl_translate_pathname(3, pathname, CAR(pair), - CADR(pair)); - goto begin; - } - } - FEerror("~S admits no logical pathname translations", 1, pathname); + CADR(pair)); + goto begin; + } + } + FEerror("~S admits no logical pathname translations", 1, pathname); @) diff --git a/src/c/predicate.d b/src/c/predicate.d index 59be543ff..c6873f52f 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -23,47 +23,47 @@ cl_object cl_identity(cl_object x) { - @(return x) + @(return x) } cl_object cl_null(cl_object x) { - @(return (Null(x) ? ECL_T : ECL_NIL)) + @(return (Null(x) ? ECL_T : ECL_NIL)) } cl_object cl_symbolp(cl_object x) { - @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)) } cl_object cl_atom(cl_object x) { - @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)) } cl_object cl_consp(cl_object x) { - @(return (CONSP(x) ? ECL_T : ECL_NIL)) + @(return (CONSP(x) ? ECL_T : ECL_NIL)) } cl_object cl_listp(cl_object x) { - @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)) + @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)) } cl_object cl_numberp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)) } -/* Used in compiled code */ +/* Used in compiled code */ bool ecl_numberp(cl_object x) { cl_type t = ecl_t_of(x); @@ -73,39 +73,39 @@ bool ecl_numberp(cl_object x) cl_object cl_integerp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)) } cl_object cl_rationalp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)) } cl_object cl_floatp(cl_object x) { - @(return (floatp(x)? ECL_T : ECL_NIL)) + @(return (floatp(x)? ECL_T : ECL_NIL)) } bool floatp(cl_object x) { - cl_type t = ecl_t_of(x); - return (t == t_singlefloat) || (t == t_doublefloat) + cl_type t = ecl_t_of(x); + return (t == t_singlefloat) || (t == t_doublefloat) #ifdef ECL_LONG_FLOAT - || (t == t_longfloat) + || (t == t_longfloat) #endif - ; + ; } cl_object cl_realp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)) } bool @@ -118,56 +118,56 @@ ecl_realp(cl_object x) cl_object cl_complexp(cl_object x) { - @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)) } cl_object cl_characterp(cl_object x) { - @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)) } #ifdef ECL_UNICODE cl_object si_base_char_p(cl_object c) { - @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)) + @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)) } #endif bool ecl_stringp(cl_object x) { - cl_type t = ecl_t_of(x); + cl_type t = ecl_t_of(x); #ifdef ECL_UNICODE - return t == t_base_string || t == t_string; + return t == t_base_string || t == t_string; #else - return t == t_base_string; + return t == t_base_string; #endif } cl_object cl_stringp(cl_object x) { - @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)) + @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)) } cl_object cl_bit_vector_p(cl_object x) { - @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)) } cl_object cl_vectorp(cl_object x) { - @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)) } cl_object cl_simple_string_p(cl_object x) { - @(return ((ECL_STRINGP(x) && + @(return ((ECL_STRINGP(x) && !ECL_ADJUSTABLE_ARRAY_P(x) && !ECL_ARRAY_HAS_FILL_POINTER_P(x) && Null(CAR(x->base_string.displaced))) ? ECL_T : ECL_NIL)) @@ -177,14 +177,14 @@ cl_simple_string_p(cl_object x) cl_object si_base_string_p(cl_object x) { - @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)) } #endif cl_object cl_simple_bit_vector_p(cl_object x) { - @(return ((ECL_BIT_VECTOR_P(x) && + @(return ((ECL_BIT_VECTOR_P(x) && !ECL_ADJUSTABLE_ARRAY_P(x) && !ECL_ARRAY_HAS_FILL_POINTER_P(x) && Null(CAR(x->vector.displaced))) ? ECL_T : ECL_NIL)) @@ -193,8 +193,8 @@ cl_simple_bit_vector_p(cl_object x) cl_object cl_simple_vector_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_vector && + cl_type t = ecl_t_of(x); + @(return ((t == t_vector && !ECL_ADJUSTABLE_ARRAY_P(x) && !ECL_ARRAY_HAS_FILL_POINTER_P(x) && Null(CAR(x->vector.displaced)) && @@ -204,58 +204,58 @@ cl_simple_vector_p(cl_object x) cl_object cl_arrayp(cl_object x) { - @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)) } cl_object cl_packagep(cl_object x) { - @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)) } cl_object cl_functionp(cl_object x) { - cl_type t; - cl_object output; + cl_type t; + cl_object output; - t = ecl_t_of(x); - if (t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure + t = ecl_t_of(x); + if (t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure #ifdef CLOS - || (t == t_instance && x->instance.isgf) + || (t == t_instance && x->instance.isgf) #endif - ) - output = ECL_T; - else - output = ECL_NIL; - @(return output) + ) + output = ECL_T; + else + output = ECL_NIL; + @(return output) } cl_object cl_compiled_function_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) } cl_object cl_eq(cl_object x, cl_object y) { - @(return ((x == y) ? ECL_T : ECL_NIL)) + @(return ((x == y) ? ECL_T : ECL_NIL)) } /* * EQL-comparison of floats. If we are using signed zeros and NaNs, * numeric comparison of floating points is not equivalent to bit-wise * equality. In particular every two NaNs always give false - * (= #1=(/ 0.0 0.0) #1#) => NIL + * (= #1=(/ 0.0 0.0) #1#) => NIL * and signed zeros always compare equal - * (= 0 -0.0) => T + * (= 0 -0.0) => T * which is not the same as what EQL should return - * (EQL #1=(/ 0.0 0.0) #1#) => T - * (EQL 0 -0.0) => NIL + * (EQL #1=(/ 0.0 0.0) #1#) => T + * (EQL 0 -0.0) => NIL * * Furthermore, we can not use bit comparisons because in some platforms * long double has unused bits that makes two long floats be = but not eql. @@ -277,75 +277,75 @@ cl_eq(cl_object x, cl_object y) bool ecl_eql(cl_object x, cl_object y) { - if (x == y) - return TRUE; + if (x == y) + return TRUE; if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) return FALSE; if (x->d.t != y->d.t) return FALSE; - switch (x->d.t) { - case t_bignum: - return (_ecl_big_compare(x, y) == 0); - case t_ratio: - return (ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den)); - case t_singlefloat: - FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); - case t_doublefloat: - FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); + switch (x->d.t) { + case t_bignum: + return (_ecl_big_compare(x, y) == 0); + case t_ratio: + return (ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den)); + case t_singlefloat: + FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); + case t_doublefloat: + FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); #ifdef ECL_LONG_FLOAT - case t_longfloat: - FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); + case t_longfloat: + FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); #endif - case t_complex: - return (ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag)); + case t_complex: + return (ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag)); #ifdef ECL_SSE2 - case t_sse_pack: - return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); + case t_sse_pack: + return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); #endif - default: - return FALSE; - } + default: + return FALSE; + } } cl_object cl_eql(cl_object x, cl_object y) { - @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)) } bool ecl_equal(register cl_object x, cl_object y) { - cl_type tx, ty; + cl_type tx, ty; BEGIN: - if (x==y) - return(TRUE); - tx = ecl_t_of(x); - ty = ecl_t_of(y); - switch (tx) { - case t_list: - if (Null(x) || Null(y)) { - /* If X is NIL, then X and Y must be EQ */ - return FALSE; - } - if (tx != ty || !ecl_equal(CAR(x), CAR(y))) - return FALSE; - x = CDR(x); - y = CDR(y); - goto BEGIN; - case t_symbol: - case t_vector: - case t_array: - case t_fixnum: - return FALSE; - case t_bignum: - return (tx == ty) && (_ecl_big_compare(x,y) == 0); - case t_ratio: - return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den); - case t_singlefloat: { + if (x==y) + return(TRUE); + tx = ecl_t_of(x); + ty = ecl_t_of(y); + switch (tx) { + case t_list: + if (Null(x) || Null(y)) { + /* If X is NIL, then X and Y must be EQ */ + return FALSE; + } + if (tx != ty || !ecl_equal(CAR(x), CAR(y))) + return FALSE; + x = CDR(x); + y = CDR(y); + goto BEGIN; + case t_symbol: + case t_vector: + case t_array: + case t_fixnum: + return FALSE; + case t_bignum: + return (tx == ty) && (_ecl_big_compare(x,y) == 0); + case t_ratio: + return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den); + case t_singlefloat: { if (tx != ty) return 0; FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); } @@ -354,188 +354,188 @@ BEGIN: FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); } #ifdef ECL_LONG_FLOAT - case t_longfloat: { + case t_longfloat: { if (tx != ty) return 0; FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); } #endif - case t_complex: - return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag); - case t_character: - return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); - case t_base_string: + case t_complex: + return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag); + case t_character: + return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); + case t_base_string: #ifdef ECL_UNICODE - case t_string: - if (ty != t_base_string && ty != t_string) - return FALSE; + case t_string: + if (ty != t_base_string && ty != t_string) + return FALSE; #else - if (ty != t_base_string) - return FALSE; + if (ty != t_base_string) + return FALSE; #endif - return ecl_string_eq(x, y); - case t_bitvector: { - cl_index i, ox, oy; - if (ty != tx) - return FALSE; - if (x->vector.fillp != y->vector.fillp) - return(FALSE); - ox = x->vector.offset; - oy = y->vector.offset; - for (i = 0; i < x->vector.fillp; i++) - if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) - !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) - return(FALSE); - return(TRUE); - } - case t_pathname: - return ty == tx && - ecl_equal(x->pathname.host, y->pathname.host) && - ecl_equal(x->pathname.device, y->pathname.device) && - ecl_equal(x->pathname.directory, y->pathname.directory) && - ecl_equal(x->pathname.name, y->pathname.name) && - ecl_equal(x->pathname.type, y->pathname.type) && - ecl_equal(x->pathname.version, y->pathname.version); - case t_foreign: - return (tx == ty) && (x->foreign.data == y->foreign.data); - default: - return FALSE; - } + return ecl_string_eq(x, y); + case t_bitvector: { + cl_index i, ox, oy; + if (ty != tx) + return FALSE; + if (x->vector.fillp != y->vector.fillp) + return(FALSE); + ox = x->vector.offset; + oy = y->vector.offset; + for (i = 0; i < x->vector.fillp; i++) + if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) + !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) + return(FALSE); + return(TRUE); + } + case t_pathname: + return ty == tx && + ecl_equal(x->pathname.host, y->pathname.host) && + ecl_equal(x->pathname.device, y->pathname.device) && + ecl_equal(x->pathname.directory, y->pathname.directory) && + ecl_equal(x->pathname.name, y->pathname.name) && + ecl_equal(x->pathname.type, y->pathname.type) && + ecl_equal(x->pathname.version, y->pathname.version); + case t_foreign: + return (tx == ty) && (x->foreign.data == y->foreign.data); + default: + return FALSE; + } } cl_object cl_equal(cl_object x, cl_object y) { - @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)) } bool ecl_equalp(cl_object x, cl_object y) { - cl_type tx, ty; - cl_index j; + cl_type tx, ty; + cl_index j; BEGIN: if (x == y) return TRUE; - tx = ecl_t_of(x); - ty = ecl_t_of(y); + tx = ecl_t_of(x); + ty = ecl_t_of(y); - switch (tx) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: + switch (tx) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_complex: - return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); - case t_vector: - case t_base_string: - case t_bitvector: + case t_complex: + return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); + case t_vector: + case t_base_string: + case t_bitvector: #ifdef ECL_UNICODE - case t_string: - if (ty != t_vector && ty != t_base_string && ty != t_bitvector - && ty != t_string) - return FALSE; + case t_string: + if (ty != t_vector && ty != t_base_string && ty != t_bitvector + && ty != t_string) + return FALSE; #else - if (ty != t_vector && ty != t_base_string && ty != t_bitvector) - return FALSE; + if (ty != t_vector && ty != t_base_string && ty != t_bitvector) + return FALSE; #endif - j = x->vector.fillp; - if (j != y->vector.fillp) - return FALSE; - goto ARRAY; - case t_array: - if (ty != t_array || x->array.rank != y->array.rank) - return FALSE; - if (x->array.rank > 1) { - cl_index i = 0; - for (i = 0; i < x->array.rank; i++) - if (x->array.dims[i] != y->array.dims[i]) + j = x->vector.fillp; + if (j != y->vector.fillp) + return FALSE; + goto ARRAY; + case t_array: + if (ty != t_array || x->array.rank != y->array.rank) + return FALSE; + if (x->array.rank > 1) { + cl_index i = 0; + for (i = 0; i < x->array.rank; i++) + if (x->array.dims[i] != y->array.dims[i]) return(FALSE); - } - if (x->array.dim != y->array.dim) - return(FALSE); - j=x->array.dim; - ARRAY: { - cl_index i; - for (i = 0; i < j; i++) - if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) - return(FALSE); - return(TRUE); } - case t_character: - return (ty == tx) && ecl_char_equal(x, y); - case t_list: - if ((tx != ty) || Null(x) || Null(y)) { - /* X is NIL but it is not EQ to Y */ - return FALSE; - } - if (!ecl_equalp(CAR(x), CAR(y))) - return(FALSE); - x = CDR(x); - y = CDR(y); - goto BEGIN; + if (x->array.dim != y->array.dim) + return(FALSE); + j=x->array.dim; + ARRAY: { + cl_index i; + for (i = 0; i < j; i++) + if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) + return(FALSE); + return(TRUE); + } + case t_character: + return (ty == tx) && ecl_char_equal(x, y); + case t_list: + if ((tx != ty) || Null(x) || Null(y)) { + /* X is NIL but it is not EQ to Y */ + return FALSE; + } + if (!ecl_equalp(CAR(x), CAR(y))) + return(FALSE); + x = CDR(x); + y = CDR(y); + goto BEGIN; #ifdef CLOS - case t_instance: { - cl_index i; - if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) - return(FALSE); - for (i = 0; i < x->instance.length; i++) - if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) - return(FALSE); - return(TRUE); - } + case t_instance: { + cl_index i; + if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) + return(FALSE); + for (i = 0; i < x->instance.length; i++) + if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) + return(FALSE); + return(TRUE); + } #else - case t_structure: { - cl_index i; - if ((tx != ty) || (x->str.name != y->str.name)) - return(FALSE); - for (i = 0; i < x->str.length; i++) - if (!ecl_equalp(x->str.self[i], y->str.self[i])) - return(FALSE); - return(TRUE); - } + case t_structure: { + cl_index i; + if ((tx != ty) || (x->str.name != y->str.name)) + return(FALSE); + for (i = 0; i < x->str.length; i++) + if (!ecl_equalp(x->str.self[i], y->str.self[i])) + return(FALSE); + return(TRUE); + } #endif /* CLOS */ - case t_pathname: - return (tx == ty) && ecl_equal(x, y); - case t_hashtable: { - if (tx != ty || + case t_pathname: + return (tx == ty) && ecl_equal(x, y); + case t_hashtable: { + if (tx != ty || x->hash.entries != y->hash.entries || - x->hash.test != y->hash.test) - return(FALSE); - { - cl_env_ptr env = ecl_process_env(); - cl_object iterator = si_hash_table_iterator(x); - do { - cl_object ndx = _ecl_funcall1(iterator); - if (Null(ndx)) { - return TRUE; - } else { - cl_object key = env->values[1]; - if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) - return FALSE; - } - } while (1); - } - } - case t_random: - return (tx == ty) && ecl_equalp(x->random.value, y->random.value); - default: - return ecl_eql(x,y); - } + x->hash.test != y->hash.test) + return(FALSE); + { + cl_env_ptr env = ecl_process_env(); + cl_object iterator = si_hash_table_iterator(x); + do { + cl_object ndx = _ecl_funcall1(iterator); + if (Null(ndx)) { + return TRUE; + } else { + cl_object key = env->values[1]; + if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) + return FALSE; + } + } while (1); + } + } + case t_random: + return (tx == ty) && ecl_equalp(x->random.value, y->random.value); + default: + return ecl_eql(x,y); + } } cl_object cl_equalp(cl_object x, cl_object y) { - @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)) } cl_object si_fixnump(cl_object x) { - @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)) } diff --git a/src/c/print.d b/src/c/print.d index 3852bb479..1111de791 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -21,388 +21,388 @@ cl_object _ecl_stream_or_default_output(cl_object stream) { - if (Null(stream)) - return ecl_symbol_value(@'*standard-output*'); - else if (stream == ECL_T) - return ecl_symbol_value(@'*terminal-io*'); - return stream; + if (Null(stream)) + return ecl_symbol_value(@'*standard-output*'); + else if (stream == ECL_T) + return ecl_symbol_value(@'*terminal-io*'); + return stream; } int ecl_print_base(void) { - cl_object object = ecl_symbol_value(@'*print-base*'); - cl_fixnum base; - unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { - ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); - FEerror("The value of *PRINT-BASE*~% ~S~%" + cl_object object = ecl_symbol_value(@'*print-base*'); + cl_fixnum base; + unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { + ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); + FEerror("The value of *PRINT-BASE*~% ~S~%" "is not of the expected type (INTEGER 2 36)", 1, object); - } - return base; + } + return base; } cl_fixnum ecl_print_level(void) { - cl_object object = ecl_symbol_value(@'*print-level*'); - cl_fixnum level; - if (object == ECL_NIL) { - level = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - level = ecl_fixnum(object); - if (level < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); - FEerror("The value of *PRINT-LEVEL*~% ~S~%" + cl_object object = ecl_symbol_value(@'*print-level*'); + cl_fixnum level; + if (object == ECL_NIL) { + level = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + level = ecl_fixnum(object); + if (level < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); + FEerror("The value of *PRINT-LEVEL*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - level = MOST_POSITIVE_FIXNUM; - } - return level; + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + level = MOST_POSITIVE_FIXNUM; + } + return level; } cl_fixnum ecl_print_length(void) { - cl_object object = ecl_symbol_value(@'*print-length*'); - cl_fixnum length; - if (object == ECL_NIL) { - length = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - length = ecl_fixnum(object); - unlikely_if (length < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); - FEerror("The value of *PRINT-LENGTH*~% ~S~%" + cl_object object = ecl_symbol_value(@'*print-length*'); + cl_fixnum length; + if (object == ECL_NIL) { + length = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + length = ecl_fixnum(object); + unlikely_if (length < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); + FEerror("The value of *PRINT-LENGTH*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - length = MOST_POSITIVE_FIXNUM; - } - return length; + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + length = MOST_POSITIVE_FIXNUM; + } + return length; } bool ecl_print_radix(void) { - return ecl_symbol_value(@'*print-radix*') != ECL_NIL; + return ecl_symbol_value(@'*print-radix*') != ECL_NIL; } cl_object ecl_print_case(void) { - cl_object output = ecl_symbol_value(@'*print-case*'); - unlikely_if (output != @':upcase' && + cl_object output = ecl_symbol_value(@'*print-case*'); + unlikely_if (output != @':upcase' && output != @':downcase' && output != @':capitalize') { - ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); - FEerror("The value of *PRINT-CASE*~% ~S~%" + ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); + FEerror("The value of *PRINT-CASE*~% ~S~%" "is not of the expected type " "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); - } - return output; + } + return output; } bool ecl_print_gensym(void) { - return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; + return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; } bool ecl_print_array(void) { - return ecl_symbol_value(@'*print-array*') != ECL_NIL; + return ecl_symbol_value(@'*print-array*') != ECL_NIL; } bool ecl_print_readably(void) { - return ecl_symbol_value(@'*print-readably*') != ECL_NIL; + return ecl_symbol_value(@'*print-readably*') != ECL_NIL; } bool ecl_print_escape(void) { - return ecl_symbol_value(@'*print-escape*') != ECL_NIL; + return ecl_symbol_value(@'*print-escape*') != ECL_NIL; } bool ecl_print_circle(void) { - return ecl_symbol_value(@'*print-circle*') != ECL_NIL; + return ecl_symbol_value(@'*print-circle*') != ECL_NIL; } @(defun write (x - &key ((:stream strm) ECL_NIL) - (array ecl_symbol_value(@'*print-array*')) - (base ecl_symbol_value(@'*print-base*')) - ((:case cas) ecl_symbol_value(@'*print-case*')) - (circle ecl_symbol_value(@'*print-circle*')) - (escape ecl_symbol_value(@'*print-escape*')) - (gensym ecl_symbol_value(@'*print-gensym*')) - (length ecl_symbol_value(@'*print-length*')) - (level ecl_symbol_value(@'*print-level*')) - (lines ecl_symbol_value(@'*print-lines*')) - (miser_width ecl_symbol_value(@'*print-miser-width*')) - (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) - (pretty ecl_symbol_value(@'*print-pretty*')) - (radix ecl_symbol_value(@'*print-radix*')) - (readably ecl_symbol_value(@'*print-readably*')) - (right_margin ecl_symbol_value(@'*print-right-margin*'))) + &key ((:stream strm) ECL_NIL) + (array ecl_symbol_value(@'*print-array*')) + (base ecl_symbol_value(@'*print-base*')) + ((:case cas) ecl_symbol_value(@'*print-case*')) + (circle ecl_symbol_value(@'*print-circle*')) + (escape ecl_symbol_value(@'*print-escape*')) + (gensym ecl_symbol_value(@'*print-gensym*')) + (length ecl_symbol_value(@'*print-length*')) + (level ecl_symbol_value(@'*print-level*')) + (lines ecl_symbol_value(@'*print-lines*')) + (miser_width ecl_symbol_value(@'*print-miser-width*')) + (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) + (pretty ecl_symbol_value(@'*print-pretty*')) + (radix ecl_symbol_value(@'*print-radix*')) + (readably ecl_symbol_value(@'*print-readably*')) + (right_margin ecl_symbol_value(@'*print-right-margin*'))) @{ - ecl_bds_bind(the_env, @'*print-array*', array); - ecl_bds_bind(the_env, @'*print-base*', base); - ecl_bds_bind(the_env, @'*print-case*', cas); - ecl_bds_bind(the_env, @'*print-circle*', circle); - ecl_bds_bind(the_env, @'*print-escape*', escape); - ecl_bds_bind(the_env, @'*print-gensym*', gensym); - ecl_bds_bind(the_env, @'*print-level*', level); - ecl_bds_bind(the_env, @'*print-length*', length); - ecl_bds_bind(the_env, @'*print-lines*', lines); - ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); - ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); - ecl_bds_bind(the_env, @'*print-pretty*', pretty); - ecl_bds_bind(the_env, @'*print-radix*', radix); - ecl_bds_bind(the_env, @'*print-readably*', readably); - ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); + ecl_bds_bind(the_env, @'*print-array*', array); + ecl_bds_bind(the_env, @'*print-base*', base); + ecl_bds_bind(the_env, @'*print-case*', cas); + ecl_bds_bind(the_env, @'*print-circle*', circle); + ecl_bds_bind(the_env, @'*print-escape*', escape); + ecl_bds_bind(the_env, @'*print-gensym*', gensym); + ecl_bds_bind(the_env, @'*print-level*', level); + ecl_bds_bind(the_env, @'*print-length*', length); + ecl_bds_bind(the_env, @'*print-lines*', lines); + ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); + ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); + ecl_bds_bind(the_env, @'*print-pretty*', pretty); + ecl_bds_bind(the_env, @'*print-radix*', radix); + ecl_bds_bind(the_env, @'*print-readably*', readably); + ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); - strm = _ecl_stream_or_default_output(strm); - si_write_object(x, strm); - ecl_force_output(strm); + strm = _ecl_stream_or_default_output(strm); + si_write_object(x, strm); + ecl_force_output(strm); - ecl_bds_unwind_n(the_env, 15); - @(return x) + ecl_bds_unwind_n(the_env, 15); + @(return x) @) @(defun prin1 (obj &optional strm) @ - ecl_prin1(obj, strm); - @(return obj) + ecl_prin1(obj, strm); + @(return obj) @) @(defun print (obj &optional strm) @ - ecl_print(obj, strm); - @(return obj) + ecl_print(obj, strm); + @(return obj) @) @(defun pprint (obj &optional strm) @ - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); - ecl_write_char('\n', strm); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind_n(the_env, 2); - @(return) + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); + ecl_write_char('\n', strm); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind_n(the_env, 2); + @(return) @) @(defun princ (obj &optional strm) @ - ecl_princ(obj, strm); - @(return obj) + ecl_princ(obj, strm); + @(return obj) @) @(defun write-char (c &optional strm) @ - /* INV: ecl_char_code() checks the type of `c' */ - strm = _ecl_stream_or_default_output(strm); - c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); - @(return c) + /* INV: ecl_char_code() checks the type of `c' */ + strm = _ecl_stream_or_default_output(strm); + c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); + @(return c) @) @(defun write-string (strng &o strm &k (start ecl_make_fixnum(0)) end) @ unlikely_if (!ECL_STRINGP(strng)) FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); - else + _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - @(return strng) + si_do_write_sequence(strng, strm, start, end); + @(return strng) @) @(defun write-line (strng &o strm &k (start ecl_make_fixnum(0)) end) @ unlikely_if (!ECL_STRINGP(strng)) FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, - start, end); - else + if (!ECL_ANSI_STREAM_P(strm)) + _ecl_funcall5(@'gray::stream-write-string', strm, strng, + start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - ecl_terpri(strm); - @(return strng) + si_do_write_sequence(strng, strm, start, end); + ecl_terpri(strm); + @(return strng) @) @(defun terpri (&optional strm) @ - ecl_terpri(strm); - @(return ECL_NIL) + ecl_terpri(strm); + @(return ECL_NIL) @) @(defun fresh-line (&optional strm) @ - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-fresh-line', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-fresh-line', strm); + } #endif - if (ecl_file_column(strm) == 0) - @(return ECL_NIL) - ecl_write_char('\n', strm); - ecl_force_output(strm); - @(return ECL_T) + if (ecl_file_column(strm) == 0) + @(return ECL_NIL) + ecl_write_char('\n', strm); + ecl_force_output(strm); + @(return ECL_T) @) @(defun finish-output (&o strm) @ - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-finish-output', strm); - } + return _ecl_funcall2(@'gray::stream-finish-output', strm); + } #endif - ecl_force_output(strm); - @(return ECL_NIL) + ecl_force_output(strm); + @(return ECL_NIL) @) @(defun force-output (&o strm) @ - strm = _ecl_stream_or_default_output(strm); - ecl_force_output(strm); - @(return ECL_NIL) + strm = _ecl_stream_or_default_output(strm); + ecl_force_output(strm); + @(return ECL_NIL) @) @(defun clear-output (&o strm) @ - strm = _ecl_stream_or_default_output(strm); - ecl_clear_output(strm); - @(return ECL_NIL) + strm = _ecl_stream_or_default_output(strm); + ecl_clear_output(strm); + @(return ECL_NIL) @) cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream) { - ecl_write_byte(integer, binary_output_stream); - @(return integer) + ecl_write_byte(integer, binary_output_stream); + @(return integer) } @(defun write-sequence (sequence stream &key (start ecl_make_fixnum(0)) end) @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) { - return _ecl_funcall5(@'gray::stream-write-sequence', - stream, sequence, start, end); - } else + if (!ECL_ANSI_STREAM_P(stream)) { + return _ecl_funcall5(@'gray::stream-write-sequence', + stream, sequence, start, end); + } else #endif - return si_do_write_sequence(sequence, stream, start, end); + return si_do_write_sequence(sequence, stream, start, end); @) cl_object ecl_princ(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - si_write_object(obj, strm); - ecl_bds_unwind_n(the_env, 2); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + si_write_object(obj, strm); + ecl_bds_unwind_n(the_env, 2); + return obj; } cl_object ecl_prin1(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind1(the_env); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind1(the_env); + return obj; } cl_object ecl_print(cl_object obj, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_terpri(strm); - ecl_prin1(obj, strm); - ecl_princ_char(' ', strm); - return obj; + strm = _ecl_stream_or_default_output(strm); + ecl_terpri(strm); + ecl_prin1(obj, strm); + ecl_princ_char(' ', strm); + return obj; } cl_object ecl_terpri(cl_object strm) { - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-terpri', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-terpri', strm); + } #endif - ecl_write_char('\n', strm); - ecl_force_output(strm); - return(ECL_NIL); + ecl_write_char('\n', strm); + ecl_force_output(strm); + return(ECL_NIL); } void ecl_write_string(cl_object strng, cl_object strm) { - cl_index i; + cl_index i; - strm = _ecl_stream_or_default_output(strm); - switch(ecl_t_of(strng)) { + strm = _ecl_stream_or_default_output(strm); + switch(ecl_t_of(strng)) { #ifdef ECL_UNICODE - case t_string: - for (i = 0; i < strng->string.fillp; i++) - ecl_write_char(strng->string.self[i], strm); - break; + case t_string: + for (i = 0; i < strng->string.fillp; i++) + ecl_write_char(strng->string.self[i], strm); + break; #endif - case t_base_string: - for (i = 0; i < strng->base_string.fillp; i++) - ecl_write_char(strng->base_string.self[i], strm); - break; - default: + case t_base_string: + for (i = 0; i < strng->base_string.fillp; i++) + ecl_write_char(strng->base_string.self[i], strm); + break; + default: FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - } - - ecl_force_output(strm); + } + + ecl_force_output(strm); } /* - THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION + THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION */ void ecl_princ_str(const char *s, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - writestr_stream(s, strm); + strm = _ecl_stream_or_default_output(strm); + writestr_stream(s, strm); } int ecl_princ_char(int c, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_write_char(c, strm); - if (c == '\n') { - ecl_force_output(strm); - } + strm = _ecl_stream_or_default_output(strm); + ecl_write_char(c, strm); + if (c == '\n') { + ecl_force_output(strm); + } return c; } diff --git a/src/c/printer/integer_to_string.d b/src/c/printer/integer_to_string.d index 3b1f526d3..bded5c1fb 100644 --- a/src/c/printer/integer_to_string.d +++ b/src/c/printer/integer_to_string.d @@ -28,8 +28,8 @@ bignum_to_string(cl_object buffer, cl_object x, cl_object base) str_size = mpz_sizeinbase(x->big.big_num, b); buffer = _ecl_ensure_buffer(buffer, str_size+1); if (str_size <= 62) { - /* With the leading sign and the trailing null character, - * only 62 digits fit in this buffer. */ + /* With the leading sign and the trailing null character, + * only 62 digits fit in this buffer. */ char txt[64]; mpz_get_str(txt, -b, x->big.big_num); _ecl_string_push_c_string(buffer, txt); @@ -45,7 +45,7 @@ bignum_to_string(cl_object buffer, cl_object x, cl_object base) static void write_base_prefix(cl_object buffer, int base) { - if (base == 2) { + if (base == 2) { _ecl_string_push_c_string(buffer, "#b"); } else if (base == 8) { _ecl_string_push_c_string(buffer, "#o"); @@ -56,11 +56,11 @@ write_base_prefix(cl_object buffer, int base) prefix[1] = base/10 + '0'; prefix[2] = base%10 + '0'; _ecl_string_push_c_string(buffer, prefix); - } else { + } else { char prefix[4] = "#0r"; prefix[1] = base + '0'; _ecl_string_push_c_string(buffer, prefix); - } + } } cl_object diff --git a/src/c/printer/print_unreadable.d b/src/c/printer/print_unreadable.d index ac81d1bcd..4cf8ca72f 100644 --- a/src/c/printer/print_unreadable.d +++ b/src/c/printer/print_unreadable.d @@ -19,16 +19,16 @@ void _ecl_write_addr(cl_object x, cl_object stream) { - cl_fixnum i, j; + cl_fixnum i, j; - i = (cl_index)x; - for (j = sizeof(i)*8-4; j >= 0; j -= 4) { - int k = (i>>j) & 0xf; - if (k < 10) - ecl_write_char('0' + k, stream); - else - ecl_write_char('a' + k - 10, stream); - } + i = (cl_index)x; + for (j = sizeof(i)*8-4; j >= 0; j -= 4) { + int k = (i>>j) & 0xf; + if (k < 10) + ecl_write_char('0' + k, stream); + else + ecl_write_char('a' + k - 10, stream); + } } void @@ -51,32 +51,32 @@ _ecl_write_unreadable(cl_object x, const char *prefix, cl_object name, cl_object cl_object si_print_unreadable_object_function(cl_object o, cl_object stream, cl_object type, cl_object id, cl_object function) { - if (ecl_print_readably()) - FEprint_not_readable(o); + if (ecl_print_readably()) + FEprint_not_readable(o); stream = _ecl_stream_or_default_output(stream); - if (ecl_print_level() == 0) { - ecl_write_char('#', stream); - } else { - writestr_stream("#<", stream); - if (!Null(type)) { - cl_index i, l; - type = cl_type_of(o); - if (!ECL_SYMBOLP(type)) { - type = @'standard-object'; - } - type = type->symbol.name; - for (i = 0, l = ecl_length(type); i < l; i++) - ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); + if (ecl_print_level() == 0) { + ecl_write_char('#', stream); + } else { + writestr_stream("#<", stream); + if (!Null(type)) { + cl_index i, l; + type = cl_type_of(o); + if (!ECL_SYMBOLP(type)) { + type = @'standard-object'; + } + type = type->symbol.name; + for (i = 0, l = ecl_length(type); i < l; i++) + ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); ecl_write_char(' ', stream); - } - if (!Null(function)) { - _ecl_funcall1(function); - } - if (!Null(id)) { - ecl_write_char(' ', stream); - _ecl_write_addr(o, stream); - } - ecl_write_char('>', stream); - } - @(return ECL_NIL) + } + if (!Null(function)) { + _ecl_funcall1(function); + } + if (!Null(id)) { + ecl_write_char(' ', stream); + _ecl_write_addr(o, stream); + } + ecl_write_char('>', stream); + } + @(return ECL_NIL) } diff --git a/src/c/printer/write_array.d b/src/c/printer/write_array.d index 268958587..9f2c3d99a 100644 --- a/src/c/printer/write_array.d +++ b/src/c/printer/write_array.d @@ -21,118 +21,118 @@ static void write_array_inner(bool vector, cl_object x, cl_object stream) { - cl_env_ptr env = ecl_process_env(); - const cl_index *adims; - cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; - cl_fixnum n, j, m, k, i; - cl_fixnum print_length; - cl_fixnum print_level; - bool readably = ecl_print_readably(); + cl_env_ptr env = ecl_process_env(); + const cl_index *adims; + cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; + cl_fixnum n, j, m, k, i; + cl_fixnum print_length; + cl_fixnum print_level; + bool readably = ecl_print_readably(); - if (vector) { - adims = &x->vector.fillp; - n = 1; - } else { - adims = x->array.dims; - n = x->array.rank; - } - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - writestr_stream(vector? "#', stream); - return; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - ecl_write_char('#', stream); - if (print_level == 0) - return; - if (readably) { - ecl_write_char('A', stream); - ecl_write_char('(', stream); - si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); - ecl_write_char(' ', stream); - if (n > 0) { - ecl_write_char('(', stream); - for (j=0; j= n) { - /* We can write the elements of the array */ - print_level -= n; - ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); - } else { - /* The elements of the array are not printed */ - n = print_level; - print_level = -1; - } - for (j = 0; j < n; j++) - subscripts[j] = 0; - for (m = 0, j = 0;;) { - for (i = j; i < n; i++) { - if (subscripts[i] == 0) { - ecl_write_char('(', stream); - if (adims[i] == 0) { - ecl_write_char(')', stream); - j = i-1; - k = 0; - goto INC; - } - } - if (subscripts[i] > 0) - ecl_write_char(' ', stream); - if (subscripts[i] >= print_length) { - writestr_stream("...)", stream); - k=adims[i]-subscripts[i]; - subscripts[i] = 0; - for (j = i+1; j < n; j++) - k *= adims[j]; - j = i-1; - goto INC; - } - } - /* FIXME: This conses! */ - if (print_level >= 0) - si_write_object(ecl_aref_unsafe(x, m), stream); - else - ecl_write_char('#', stream); - j = n-1; - k = 1; + if (vector) { + adims = &x->vector.fillp; + n = 1; + } else { + adims = x->array.dims; + n = x->array.rank; + } + if (readably) { + print_length = MOST_POSITIVE_FIXNUM; + print_level = MOST_POSITIVE_FIXNUM; + } else { + if (!ecl_print_array()) { + writestr_stream(vector? "#', stream); + return; + } + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + ecl_write_char('#', stream); + if (print_level == 0) + return; + if (readably) { + ecl_write_char('A', stream); + ecl_write_char('(', stream); + si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); + ecl_write_char(' ', stream); + if (n > 0) { + ecl_write_char('(', stream); + for (j=0; j= n) { + /* We can write the elements of the array */ + print_level -= n; + ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); + } else { + /* The elements of the array are not printed */ + n = print_level; + print_level = -1; + } + for (j = 0; j < n; j++) + subscripts[j] = 0; + for (m = 0, j = 0;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + ecl_write_char('(', stream); + if (adims[i] == 0) { + ecl_write_char(')', stream); + j = i-1; + k = 0; + goto INC; + } + } + if (subscripts[i] > 0) + ecl_write_char(' ', stream); + if (subscripts[i] >= print_length) { + writestr_stream("...)", stream); + k=adims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= adims[j]; + j = i-1; + goto INC; + } + } + /* FIXME: This conses! */ + if (print_level >= 0) + si_write_object(ecl_aref_unsafe(x, m), stream); + else + ecl_write_char('#', stream); + j = n-1; + k = 1; - INC: - while (j >= 0) { - if (++subscripts[j] < adims[j]) - break; - subscripts[j] = 0; - ecl_write_char(')', stream); - --j; - } - if (j < 0) - break; - m += k; - } - if (print_level >= 0) { - ecl_bds_unwind1(env); - } - if (readably) { - ecl_write_char(')', stream); - } + INC: + while (j >= 0) { + if (++subscripts[j] < adims[j]) + break; + subscripts[j] = 0; + ecl_write_char(')', stream); + --j; + } + if (j < 0) + break; + m += k; + } + if (print_level >= 0) { + ecl_bds_unwind1(env); + } + if (readably) { + ecl_write_char(')', stream); + } } void @@ -156,14 +156,14 @@ _ecl_write_string(cl_object x, cl_object stream) for (ndx = 0; ndx < x->string.fillp; ndx++) ecl_write_char(x->string.self[ndx], stream); } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->string.fillp; ndx++) { - ecl_character c = x->string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->string.fillp; ndx++) { + ecl_character c = x->string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); } } #endif @@ -176,14 +176,14 @@ _ecl_write_base_string(cl_object x, cl_object stream) for (ndx = 0; ndx < x->base_string.fillp; ndx++) ecl_write_char(x->base_string.self[ndx], stream); } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->base_string.fillp; ndx++) { - int c = x->base_string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->base_string.fillp; ndx++) { + int c = x->base_string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); } } @@ -196,11 +196,11 @@ _ecl_write_bitvector(cl_object x, cl_object stream) ecl_write_char('>', stream); } else { cl_index ndx; - writestr_stream("#*", stream); - for (ndx = 0; ndx < x->vector.fillp; ndx++) - if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) - ecl_write_char('1', stream); - else - ecl_write_char('0', stream); + writestr_stream("#*", stream); + for (ndx = 0; ndx < x->vector.fillp; ndx++) + if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) + ecl_write_char('1', stream); + else + ecl_write_char('0', stream); } } diff --git a/src/c/printer/write_code.d b/src/c/printer/write_code.d index 74080219a..66a356417 100644 --- a/src/c/printer/write_code.d +++ b/src/c/printer/write_code.d @@ -51,13 +51,13 @@ _ecl_write_bclosure(cl_object x, cl_object stream) { if (ecl_print_readably()) { cl_object lex = x->bclosure.lex; - if (Null(lex)) { - _ecl_write_bytecodes(x->bclosure.code, stream); - } else { - writestr_stream("#Y", stream); - si_write_ugly_object(cl_list(2, x->bclosure.code, lex), - stream); - } + if (Null(lex)) { + _ecl_write_bytecodes(x->bclosure.code, stream); + } else { + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(2, x->bclosure.code, lex), + stream); + } } else { cl_object name = x->bytecodes.name; writestr_stream("#d.t != t_symbol) || (Null(x->symbol.hpack)))) - { - cl_object circle_counter; - cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - if (circle_counter == ECL_NIL) { - cl_env_ptr env = ecl_process_env(); - cl_object hash = - cl__make_hash_table(@'eq', - ecl_make_fixnum(1024), + circle = ecl_print_circle(); + if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && + (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) + { + cl_object circle_counter; + cl_fixnum code; + circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + if (circle_counter == ECL_NIL) { + cl_env_ptr env = ecl_process_env(); + cl_object hash = + cl__make_hash_table(@'eq', + ecl_make_fixnum(1024), cl_core.rehash_size, cl_core.rehash_threshold); - ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); - ecl_bds_bind(env, @'si::*circle-stack*', hash); - si_write_object(x, cl_core.null_stream); - ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); - si_write_object(x, stream); - cl_clrhash(hash); - ecl_bds_unwind_n(env, 2); - goto OUTPUT; - } - code = search_print_circle(x); - if (!ECL_FIXNUMP(circle_counter)) { - /* We are only inspecting the object to be printed. */ - /* Only run X if it was not referenced before */ - if (code != 0) + ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); + ecl_bds_bind(env, @'si::*circle-stack*', hash); + si_write_object(x, cl_core.null_stream); + ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); + si_write_object(x, stream); + cl_clrhash(hash); + ecl_bds_unwind_n(env, 2); + goto OUTPUT; + } + code = search_print_circle(x); + if (!ECL_FIXNUMP(circle_counter)) { + /* We are only inspecting the object to be printed. */ + /* Only run X if it was not referenced before */ + if (code != 0) goto OUTPUT; - } else if (code == 0) { - /* Object is not referenced twice */ - } else if (code < 0) { - /* Object is referenced twice. We print its definition */ - ecl_write_char('#', stream); - _ecl_write_fixnum(-code, stream); - ecl_write_char('=', stream); - } else { - /* Second reference to the object */ - ecl_write_char('#', stream); - _ecl_write_fixnum(code, stream); - ecl_write_char('#', stream); - goto OUTPUT; - } - } - return si_write_ugly_object(x, stream); + } else if (code == 0) { + /* Object is not referenced twice */ + } else if (code < 0) { + /* Object is referenced twice. We print its definition */ + ecl_write_char('#', stream); + _ecl_write_fixnum(-code, stream); + ecl_write_char('=', stream); + } else { + /* Second reference to the object */ + ecl_write_char('#', stream); + _ecl_write_fixnum(code, stream); + ecl_write_char('#', stream); + goto OUTPUT; + } + } + return si_write_ugly_object(x, stream); OUTPUT: @(return x) } diff --git a/src/c/printer/write_sse.d b/src/c/printer/write_sse.d index c9b485450..54aa8ac40 100644 --- a/src/c/printer/write_sse.d +++ b/src/c/printer/write_sse.d @@ -21,70 +21,70 @@ #ifdef ECL_SSE2 static int is_all_FF(void *ptr, int size) { - int i; - for (i = 0; i < size; i++) - if (((unsigned char*)ptr)[i] != 0xFF) - return 0; - return 1; + int i; + for (i = 0; i < size; i++) + if (((unsigned char*)ptr)[i] != 0xFF) + return 0; + return 1; } static void write_sse_float(float v, cl_object stream) { - if (is_all_FF(&v, sizeof(float))) { - writestr_stream(" TRUE", stream); - } else { + if (is_all_FF(&v, sizeof(float))) { + writestr_stream(" TRUE", stream); + } else { ecl_write_char(' ', stream); si_write_ugly_object(ecl_make_single_float(v), stream); - } + } } static void write_sse_double(double v, cl_object stream) { - if (is_all_FF(&v, sizeof(double))) - writestr_stream(" TRUE", stream); + if (is_all_FF(&v, sizeof(double))) + writestr_stream(" TRUE", stream); else { ecl_write_char(' ', stream); si_write_ugly_object(ecl_make_double_float(v), stream); - } + } } static void write_sse_pack(cl_object x, cl_object stream) { - int i; - cl_elttype etype = x->sse.elttype; - cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); + int i; + cl_elttype etype = x->sse.elttype; + cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); - if (mode != ECL_NIL) { - if (mode == @':float') etype = ecl_aet_sf; - else if (mode == @':double') etype = ecl_aet_df; - else etype = ecl_aet_b8; - } + if (mode != ECL_NIL) { + if (mode == @':float') etype = ecl_aet_sf; + else if (mode == @':double') etype = ecl_aet_df; + else etype = ecl_aet_b8; + } - switch (etype) { - case ecl_aet_sf: - for (i = 0; i < 4; i++) + switch (etype) { + case ecl_aet_sf: + for (i = 0; i < 4; i++) write_sse_float(x->sse.data.sf[i], stream); - break; - case ecl_aet_df: - write_sse_double(x->sse.data.df[0], stream); - write_sse_double(x->sse.data.df[1], stream); - break; - default: { + break; + case ecl_aet_df: + write_sse_double(x->sse.data.df[0], stream); + write_sse_double(x->sse.data.df[1], stream); + break; + default: { cl_object buffer = si_get_buffer_string(); - for (i = 0; i < 16; i++) { + for (i = 0; i < 16; i++) { ecl_string_push_extend(buffer, ' '); if (i%4 == 0) ecl_string_push_extend(buffer, ' '); si_integer_to_string(buffer, ecl_make_fixnum(x->sse.data.b8[i]), ecl_make_fixnum(16), ECL_NIL, ECL_NIL); - } + } si_do_write_sequence(buffer, stream, ecl_make_fixnum(0), ECL_NIL); si_put_buffer_string(buffer); break; } - } + } } void diff --git a/src/c/printer/write_symbol.d b/src/c/printer/write_symbol.d index a37662d03..ac77fb3c5 100644 --- a/src/c/printer/write_symbol.d +++ b/src/c/printer/write_symbol.d @@ -21,48 +21,48 @@ static bool potential_number_p(cl_object s, int base) { - /* See ANSI 2.3.1.1 */ - static cl_index i, l; + /* See ANSI 2.3.1.1 */ + static cl_index i, l; ecl_character c; - /* A potential number must contain at least one digit */ - bool some_digit = FALSE; + /* A potential number must contain at least one digit */ + bool some_digit = FALSE; - l = s->base_string.fillp; - if (l == 0) - return FALSE; - c = ecl_char(s, 0); + l = s->base_string.fillp; + if (l == 0) + return FALSE; + c = ecl_char(s, 0); - /* A potential number must begin with a digit, sign or + /* A potential number must begin with a digit, sign or extension character (^ _) */ - if (ecl_digitp(c,base) >= 0) - some_digit = TRUE; - else if (c != '+' && c != '-' && c != '^' && c != '_') - return FALSE; + if (ecl_digitp(c,base) >= 0) + some_digit = TRUE; + else if (c != '+' && c != '-' && c != '^' && c != '_') + return FALSE; - /* A potential number cannot end with a sign */ + /* A potential number cannot end with a sign */ c = ecl_char(s, l-1); - if (c == '+' || c == '-') - return FALSE; + if (c == '+' || c == '-') + return FALSE; - for (i = 1; i < l; i++) { - c = ecl_char(s, i); - /* It can only contain digits, signs, ratio markers, - * extension characters and number markers. Number - * markers are letters, but two adjacent letters fail - * to be a number marker. */ - if (ecl_digitp(c, base) >= 0) { - some_digit = TRUE; - } else if (c == '+' || c == '-' || - c == '/' || c == '.' || c == '^' || c == '_') { - continue; - } else if (ecl_alpha_char_p(c) && - (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { - continue; - } else { - return FALSE; - } - } - return some_digit; + for (i = 1; i < l; i++) { + c = ecl_char(s, i); + /* It can only contain digits, signs, ratio markers, + * extension characters and number markers. Number + * markers are letters, but two adjacent letters fail + * to be a number marker. */ + if (ecl_digitp(c, base) >= 0) { + some_digit = TRUE; + } else if (c == '+' || c == '-' || + c == '/' || c == '.' || c == '^' || c == '_') { + continue; + } else if (ecl_alpha_char_p(c) && + (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { + continue; + } else { + return FALSE; + } + } + return some_digit; } #define needs_to_be_inverted(s) (ecl_string_case(s) != 0) @@ -70,149 +70,149 @@ potential_number_p(cl_object s, int base) static bool all_dots(cl_object s) { - cl_index i; - for (i = 0; i < s->base_string.fillp; i++) - if (ecl_char(s, i) != '.') - return 0; - return 1; + cl_index i; + for (i = 0; i < s->base_string.fillp; i++) + if (ecl_char(s, i) != '.') + return 0; + return 1; } static bool needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) { - int action = readtable->readtable.read_case; - cl_index i; - if (potential_number_p(s, ecl_print_base())) - return 1; - /* The value of *PRINT-ESCAPE* is T. We need to check whether the - * symbol name S needs to be escaped. This will happen if it has some - * strange character, or if it has a lowercase character (because such - * a character cannot be read with the standard readtable) or if the - * string has to be escaped according to readtable case and the rules - * of 22.1.3.3.2. */ - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - int syntax = ecl_readtable_get(readtable, c, 0); - if (syntax != cat_constituent || + int action = readtable->readtable.read_case; + cl_index i; + if (potential_number_p(s, ecl_print_base())) + return 1; + /* The value of *PRINT-ESCAPE* is T. We need to check whether the + * symbol name S needs to be escaped. This will happen if it has some + * strange character, or if it has a lowercase character (because such + * a character cannot be read with the standard readtable) or if the + * string has to be escaped according to readtable case and the rules + * of 22.1.3.3.2. */ + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + int syntax = ecl_readtable_get(readtable, c, 0); + if (syntax != cat_constituent || ecl_invalid_character_p(c) || (c) == ':') - return 1; - if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) - return 1; - if (ecl_lower_case_p(c)) - return 1; - } - return 0; + return 1; + if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) + return 1; + if (ecl_lower_case_p(c)) + return 1; + } + return 0; } static void write_symbol_string(cl_object s, int action, cl_object print_case, - cl_object stream, bool escape) + cl_object stream, bool escape) { - cl_index i; - bool capitalize; - if (action == ecl_case_invert) { - if (!needs_to_be_inverted(s)) - action = ecl_case_preserve; - } - if (escape) - ecl_write_char('|', stream); - capitalize = 1; - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - if (escape) { - if (c == '|' || c == '\\') { - ecl_write_char('\\', stream); - } - } else if (action != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_upcase) && - ((print_case == @':downcase') || - ((print_case == @':capitalize') && !capitalize)))) - { - c = ecl_char_downcase(c); - } - capitalize = 0; - } else if (ecl_lower_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_downcase) && - ((print_case == @':upcase') || - ((print_case == @':capitalize') && capitalize)))) - { - c = ecl_char_upcase(c); - } - capitalize = 0; - } else { - capitalize = !ecl_alphanumericp(c); - } - } - ecl_write_char(c, stream); - } - if (escape) - ecl_write_char('|', stream); + cl_index i; + bool capitalize; + if (action == ecl_case_invert) { + if (!needs_to_be_inverted(s)) + action = ecl_case_preserve; + } + if (escape) + ecl_write_char('|', stream); + capitalize = 1; + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + if (escape) { + if (c == '|' || c == '\\') { + ecl_write_char('\\', stream); + } + } else if (action != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_upcase) && + ((print_case == @':downcase') || + ((print_case == @':capitalize') && !capitalize)))) + { + c = ecl_char_downcase(c); + } + capitalize = 0; + } else if (ecl_lower_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_downcase) && + ((print_case == @':upcase') || + ((print_case == @':capitalize') && capitalize)))) + { + c = ecl_char_upcase(c); + } + capitalize = 0; + } else { + capitalize = !ecl_alphanumericp(c); + } + } + ecl_write_char(c, stream); + } + if (escape) + ecl_write_char('|', stream); } static bool forced_print_package(cl_object package) { - cl_object print_package = ecl_symbol_value(@'si::*print-package*'); - return !Null(print_package) && (print_package != package); + cl_object print_package = ecl_symbol_value(@'si::*print-package*'); + return !Null(print_package) && (print_package != package); } void _ecl_write_symbol(cl_object x, cl_object stream) { - cl_object readtable = ecl_current_readtable(); - cl_object print_case = ecl_print_case(); - cl_object package; - cl_object name; - int intern_flag; - bool print_readably = ecl_print_readably(); - bool forced_package = 0; + cl_object readtable = ecl_current_readtable(); + cl_object print_case = ecl_print_case(); + cl_object package; + cl_object name; + int intern_flag; + bool print_readably = ecl_print_readably(); + bool forced_package = 0; - if (Null(x)) { - package = ECL_NIL_SYMBOL->symbol.hpack; - name = ECL_NIL_SYMBOL->symbol.name; - } else { - package = x->symbol.hpack; - name = x->symbol.name; - } + if (Null(x)) { + package = ECL_NIL_SYMBOL->symbol.hpack; + name = ECL_NIL_SYMBOL->symbol.name; + } else { + package = x->symbol.hpack; + name = x->symbol.name; + } - if (!print_readably && !ecl_print_escape()) { - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, 0); - return; - } - /* From here on, print-escape is true which means that it should - * be possible to recover the same symbol by reading it with - * the standard readtable (which has readtable-case = :UPCASE) - */ - if (Null(package)) { - if (print_readably || ecl_print_gensym()) - writestr_stream("#:", stream); - } else if (package == cl_core.keyword_package) { - ecl_write_char(':', stream); - } else if ((forced_package = forced_print_package(package)) - || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x - || (intern_flag == 0)) - { - cl_object name = package->pack.name; - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, - needs_to_be_escaped(name, readtable, print_case)); - if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) - ecl_internal_error("can't print symbol"); - if (intern_flag == ECL_INTERNAL || forced_package) { - writestr_stream("::", stream); - } else if (intern_flag == ECL_EXTERNAL) { - ecl_write_char(':', stream); - } else { - FEerror("Pathological symbol --- cannot print.", 0); - } - } - write_symbol_string(name, readtable->readtable.read_case, print_case, stream, - needs_to_be_escaped(name, readtable, print_case) || - all_dots(name)); + if (!print_readably && !ecl_print_escape()) { + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, 0); + return; + } + /* From here on, print-escape is true which means that it should + * be possible to recover the same symbol by reading it with + * the standard readtable (which has readtable-case = :UPCASE) + */ + if (Null(package)) { + if (print_readably || ecl_print_gensym()) + writestr_stream("#:", stream); + } else if (package == cl_core.keyword_package) { + ecl_write_char(':', stream); + } else if ((forced_package = forced_print_package(package)) + || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x + || (intern_flag == 0)) + { + cl_object name = package->pack.name; + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, + needs_to_be_escaped(name, readtable, print_case)); + if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) + ecl_internal_error("can't print symbol"); + if (intern_flag == ECL_INTERNAL || forced_package) { + writestr_stream("::", stream); + } else if (intern_flag == ECL_EXTERNAL) { + ecl_write_char(':', stream); + } else { + FEerror("Pathological symbol --- cannot print.", 0); + } + } + write_symbol_string(name, readtable->readtable.read_case, print_case, stream, + needs_to_be_escaped(name, readtable, print_case) || + all_dots(name)); } diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index 5d15cd0aa..d373f158c 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -123,17 +123,17 @@ static void write_character(cl_object x, cl_object stream) { int i = ECL_CHAR_CODE(x); - if (!ecl_print_escape() && !ecl_print_readably()) { - ecl_write_char(i, stream); - } else { - writestr_stream("#\\", stream); - if (i < 32 || i >= 127) { - cl_object name = cl_char_name(ECL_CODE_CHAR(i)); - writestr_stream((char*)name->base_string.self, stream); - } else { - ecl_write_char(i, stream); - } - } + if (!ecl_print_escape() && !ecl_print_readably()) { + ecl_write_char(i, stream); + } else { + writestr_stream("#\\", stream); + if (i < 32 || i >= 127) { + cl_object name = cl_char_name(ECL_CODE_CHAR(i)); + writestr_stream((char*)name->base_string.self, stream); + } else { + ecl_write_char(i, stream); + } + } } static void @@ -148,21 +148,21 @@ write_package(cl_object x, cl_object stream) static void write_hashtable(cl_object x, cl_object stream) { - if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { - cl_object make = - cl_list(9, @'make-hash-table', - @':size', cl_hash_table_size(x), - @':rehash-size', cl_hash_table_rehash_size(x), - @':rehash-threshold', cl_hash_table_rehash_threshold(x), - @':test', cl_list(2, @'quote', cl_hash_table_test(x))); - cl_object init = - cl_list(3, @'ext::hash-table-fill', make, - cl_list(2, @'quote', si_hash_table_content(x))); - writestr_stream("#.", stream); - si_write_ugly_object(init, stream); - } else { - _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); - } + if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { + cl_object make = + cl_list(9, @'make-hash-table', + @':size', cl_hash_table_size(x), + @':rehash-size', cl_hash_table_rehash_size(x), + @':rehash-threshold', cl_hash_table_rehash_threshold(x), + @':test', cl_list(2, @'quote', cl_hash_table_test(x))); + cl_object init = + cl_list(3, @'ext::hash-table-fill', make, + cl_list(2, @'quote', si_hash_table_content(x))); + writestr_stream("#.", stream); + si_write_ugly_object(init, stream); + } else { + _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); + } } static void @@ -421,71 +421,71 @@ typedef void (*printer)(cl_object x, cl_object stream); static printer dispatch[FREE+1] = { 0 /* t_start = 0 */, - _ecl_write_list, /* t_list = 1 */ - write_character, /* t_character = 2 */ - write_integer, /* t_fixnum = 3 */ - write_integer, /* t_bignum = 4 */ - write_ratio, /* t_ratio */ - write_float, /* t_singlefloat */ - write_float, /* t_doublefloat */ + _ecl_write_list, /* t_list = 1 */ + write_character, /* t_character = 2 */ + write_integer, /* t_fixnum = 3 */ + write_integer, /* t_bignum = 4 */ + write_ratio, /* t_ratio */ + write_float, /* t_singlefloat */ + write_float, /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - write_float, /* t_longfloat */ + write_float, /* t_longfloat */ #endif - write_complex, /* t_complex */ - _ecl_write_symbol, /* t_symbol */ - write_package, /* t_package */ - write_hashtable, /* t_hashtable */ - _ecl_write_array, /* t_array */ - _ecl_write_vector, /* t_vector */ + write_complex, /* t_complex */ + _ecl_write_symbol, /* t_symbol */ + write_package, /* t_package */ + write_hashtable, /* t_hashtable */ + _ecl_write_array, /* t_array */ + _ecl_write_vector, /* t_vector */ #ifdef ECL_UNICODE - _ecl_write_string, /* t_string */ + _ecl_write_string, /* t_string */ #endif - _ecl_write_base_string, /* t_base_string */ - _ecl_write_bitvector, /* t_bitvector */ - write_stream, /* t_stream */ - write_random, /* t_random */ - write_readtable, /* t_readtable */ - write_pathname, /* t_pathname */ - _ecl_write_bytecodes, /* t_bytecodes */ - _ecl_write_bclosure, /* t_bclosure */ - write_cfun, /* t_cfun */ - write_cfun, /* t_cfunfixed */ - write_cclosure, /* t_cclosure */ + _ecl_write_base_string, /* t_base_string */ + _ecl_write_bitvector, /* t_bitvector */ + write_stream, /* t_stream */ + write_random, /* t_random */ + write_readtable, /* t_readtable */ + write_pathname, /* t_pathname */ + _ecl_write_bytecodes, /* t_bytecodes */ + _ecl_write_bclosure, /* t_bclosure */ + write_cfun, /* t_cfun */ + write_cfun, /* t_cfunfixed */ + write_cclosure, /* t_cclosure */ #ifdef CLOS - write_instance, /* t_instance */ + write_instance, /* t_instance */ #else - write_structure, /* t_structure */ + write_structure, /* t_structure */ #endif /* CLOS */ #ifdef ECL_THREADS - write_process, /* t_process */ - write_lock, /* t_lock */ - write_lock, /* t_rwlock */ - write_condition_variable, /* t_condition_variable */ + write_process, /* t_process */ + write_lock, /* t_lock */ + write_lock, /* t_rwlock */ + write_condition_variable, /* t_condition_variable */ write_semaphore, /* t_semaphore */ write_barrier, /* t_barrier */ write_mailbox, /* t_mailbox */ #endif - write_codeblock, /* t_codeblock */ - write_foreign, /* t_foreign */ - write_frame, /* t_frame */ - write_weak_pointer, /* t_weak_pointer */ + write_codeblock, /* t_codeblock */ + write_foreign, /* t_foreign */ + write_frame, /* t_frame */ + write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 - _ecl_write_sse, /* t_sse_pack */ + _ecl_write_sse, /* t_sse_pack */ #endif - /* t_end */ + /* t_end */ }; cl_object si_write_ugly_object(cl_object x, cl_object stream) { - if (x == OBJNULL) { - if (ecl_print_readably()) + if (x == OBJNULL) { + if (ecl_print_readably()) FEprint_not_readable(x); - writestr_stream("#", stream); - } else { + writestr_stream("#", stream); + } else { int t = ecl_t_of(x); printer f = (t >= t_end)? write_illegal : dispatch[t]; f(x, stream); } - @(return x) + @(return x) } diff --git a/src/c/read.d b/src/c/read.d index c4a66fa96..ceb296e82 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -55,54 +55,54 @@ static cl_object dispatch_macro_character(cl_object table, cl_object strm, int c cl_object si_get_buffer_string() { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_object output; - if (pool == ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_object output; + if (pool == ECL_NIL) { #ifdef ECL_UNICODE - output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } else { - output = CAR(pool); - env->string_pool = CDR(pool); - } - TOKEN_STRING_FILLP(output) = 0; - @(return output) + } else { + output = CAR(pool); + env->string_pool = CDR(pool); + } + TOKEN_STRING_FILLP(output) = 0; + @(return output) } cl_object si_put_buffer_string(cl_object string) { - if (string != ECL_NIL) { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_index l = 0; - if (pool != ECL_NIL) { - /* We store the size of the pool in the string index */ - l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); - } - if (l < ECL_MAX_STRING_POOL_SIZE) { - /* Ok, by ignoring the following code, here we - * are doing like SBCL: we simply grow the - * input buffer and do not care about its - * size. */ + if (string != ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_index l = 0; + if (pool != ECL_NIL) { + /* We store the size of the pool in the string index */ + l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); + } + if (l < ECL_MAX_STRING_POOL_SIZE) { + /* Ok, by ignoring the following code, here we + * are doing like SBCL: we simply grow the + * input buffer and do not care about its + * size. */ #if 0 - if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { - /* String has been enlarged. Cut it. */ + if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { + /* String has been enlarged. Cut it. */ #ifdef ECL_UNICODE - string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } + } #endif - TOKEN_STRING_FILLP(string) = l+1; - env->string_pool = CONS(string, pool); - } - } - @(return) + TOKEN_STRING_FILLP(string) = l+1; + env->string_pool = CONS(string, pool); + } + } + @(return) } static void extra_argument (int c, cl_object stream, cl_object d); @@ -112,15 +112,15 @@ static cl_object do_read_delimited_list(int d, cl_object strm, bool proper_list) cl_object ecl_read_object_non_recursive(cl_object in) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); - x = ecl_read_object(in); - x = patch_sharp(env, x); - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + x = ecl_read_object(in); + x = patch_sharp(env, x); + ecl_bds_unwind_n(env, 2); + return x; } /* @@ -133,314 +133,314 @@ ecl_read_object_non_recursive(cl_object in) static void invert_buffer_case(cl_object x, cl_object escape_list, int sign) { - cl_fixnum high_limit, low_limit; - cl_fixnum i = TOKEN_STRING_FILLP(x); - do { - if (escape_list != ECL_NIL) { - cl_object escape_interval = CAR(escape_list); - high_limit = ecl_fixnum(CAR(escape_interval)); - low_limit = ecl_fixnum(CDR(escape_interval)); - escape_list = CDR(escape_list); - } else { - high_limit = low_limit = -1; - } - for (; i > high_limit; i--) { - /* The character is not escaped */ - int c = TOKEN_STRING_CHAR(x,i); - if (ecl_upper_case_p(c) && (sign < 0)) { - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c) && (sign > 0)) { - c = ecl_char_upcase(c); - } - TOKEN_STRING_CHAR_SET(x,i,c); - } - for (; i > low_limit; i--) { - /* The character is within an escaped interval */ - ; - } - } while (i >= 0); + cl_fixnum high_limit, low_limit; + cl_fixnum i = TOKEN_STRING_FILLP(x); + do { + if (escape_list != ECL_NIL) { + cl_object escape_interval = CAR(escape_list); + high_limit = ecl_fixnum(CAR(escape_interval)); + low_limit = ecl_fixnum(CDR(escape_interval)); + escape_list = CDR(escape_list); + } else { + high_limit = low_limit = -1; + } + for (; i > high_limit; i--) { + /* The character is not escaped */ + int c = TOKEN_STRING_CHAR(x,i); + if (ecl_upper_case_p(c) && (sign < 0)) { + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c) && (sign > 0)) { + c = ecl_char_upcase(c); + } + TOKEN_STRING_CHAR_SET(x,i,c); + } + for (; i > low_limit; i--) { + /* The character is within an escaped interval */ + ; + } + } while (i >= 0); } static cl_object ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags, enum ecl_chattrib a) { - cl_object x, token; - int c, base; - cl_object p; - cl_index length, i; - int colon, intern_flag; - bool external_symbol; + cl_object x, token; + int c, base; + cl_object p; + cl_index length, i; + int colon, intern_flag; + bool external_symbol; cl_env_ptr the_env = ecl_process_env(); - cl_object rtbl = ecl_current_readtable(); - enum ecl_readtable_case read_case = rtbl->readtable.read_case; - cl_object escape_list; /* intervals of escaped characters */ - cl_fixnum upcase; /* # uppercase characters - # downcase characters */ - cl_fixnum count; /* number of unescaped characters */ - bool suppress = read_suppress; - if (a != cat_constituent) { - c = 0; - goto LOOP; - } + cl_object rtbl = ecl_current_readtable(); + enum ecl_readtable_case read_case = rtbl->readtable.read_case; + cl_object escape_list; /* intervals of escaped characters */ + cl_fixnum upcase; /* # uppercase characters - # downcase characters */ + cl_fixnum count; /* number of unescaped characters */ + bool suppress = read_suppress; + if (a != cat_constituent) { + c = 0; + goto LOOP; + } BEGIN: - do { - c = ecl_read_char(in); - if (c == delimiter) { + do { + c = ecl_read_char(in); + if (c == delimiter) { the_env->nvalues = 0; - return OBJNULL; + return OBJNULL; } - if (c == EOF) - FEend_of_file(in); - a = ecl_readtable_get(rtbl, c, &x); - } while (a == cat_whitespace); - if ((a == cat_terminating || a == cat_non_terminating) && + if (c == EOF) + FEend_of_file(in); + a = ecl_readtable_get(rtbl, c, &x); + } while (a == cat_whitespace); + if ((a == cat_terminating || a == cat_non_terminating) && (flags != ECL_READ_ONLY_TOKEN)) { - cl_object o; - if (ECL_HASH_TABLE_P(x)) { - o = dispatch_macro_character(x, in, c); - } else { - o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); - } - if (the_env->nvalues == 0) { + cl_object o; + if (ECL_HASH_TABLE_P(x)) { + o = dispatch_macro_character(x, in, c); + } else { + o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); + } + if (the_env->nvalues == 0) { if (flags == ECL_READ_RETURN_IGNORABLE) return ECL_NIL; goto BEGIN; } - unlikely_if (the_env->nvalues > 1) { + unlikely_if (the_env->nvalues > 1) { FEerror("The readmacro ~S returned ~D values.", 2, x, ecl_make_fixnum(the_env->nvalues)); } - return o; - } + return o; + } LOOP: - p = escape_list = ECL_NIL; - upcase = count = length = 0; - external_symbol = colon = 0; - token = si_get_buffer_string(); - for (;;) { - if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && + p = escape_list = ECL_NIL; + upcase = count = length = 0; + external_symbol = colon = 0; + token = si_get_buffer_string(); + for (;;) { + if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && a == cat_constituent) { - colon++; - goto NEXT; - } - if (colon > 2) { - while (colon--) { - ecl_string_push_extend(token, ':'); - length++; - } - } else if (colon) { - external_symbol = (colon == 1); - TOKEN_STRING_CHAR_SET(token,length,'\0'); - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (length == 0) { - p = cl_core.keyword_package; - external_symbol = 0; - } else { - p = ecl_find_package_nolock(token); - } - if (Null(p) && !suppress) { - /* When loading binary files, we sometimes must create - symbols whose package has not yet been maked. We - allow it, but later on in ecl_init_module we make sure that - all referenced packages have been properly built. - */ - cl_object name = cl_copy_seq(token); - unlikely_if (Null(the_env->packages_to_be_created_p)) { - FEerror("There is no package with the name ~A.", - 1, name); - } + colon++; + goto NEXT; + } + if (colon > 2) { + while (colon--) { + ecl_string_push_extend(token, ':'); + length++; + } + } else if (colon) { + external_symbol = (colon == 1); + TOKEN_STRING_CHAR_SET(token,length,'\0'); + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); + } + } + if (length == 0) { + p = cl_core.keyword_package; + external_symbol = 0; + } else { + p = ecl_find_package_nolock(token); + } + if (Null(p) && !suppress) { + /* When loading binary files, we sometimes must create + symbols whose package has not yet been maked. We + allow it, but later on in ecl_init_module we make sure that + all referenced packages have been properly built. + */ + cl_object name = cl_copy_seq(token); + unlikely_if (Null(the_env->packages_to_be_created_p)) { + FEerror("There is no package with the name ~A.", + 1, name); + } p = _ecl_package_to_be_created(the_env, name); - } - TOKEN_STRING_FILLP(token) = length = 0; - upcase = count = colon = 0; - escape_list = ECL_NIL; - } - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(length), - ecl_make_fixnum(length)), - escape_list); - } else { - escape_list = ECL_T; - } - ecl_string_push_extend(token, c); - length++; - goto NEXT; - } - if (a == cat_multiple_escape) { - cl_index begin = length; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - length++; - } - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(begin), - ecl_make_fixnum(length-1)), - escape_list); - } else { - escape_list = ECL_T; - } - goto NEXT; - } - if (a == cat_whitespace || a == cat_terminating) { - ecl_unread_char(c, in); - break; - } - unlikely_if (ecl_invalid_character_p(c)) { - FEreader_error("Found invalid character ~:C", in, + } + TOKEN_STRING_FILLP(token) = length = 0; + upcase = count = colon = 0; + escape_list = ECL_NIL; + } + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(length), + ecl_make_fixnum(length)), + escape_list); + } else { + escape_list = ECL_T; + } + ecl_string_push_extend(token, c); + length++; + goto NEXT; + } + if (a == cat_multiple_escape) { + cl_index begin = length; + for (;;) { + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + length++; + } + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(begin), + ecl_make_fixnum(length-1)), + escape_list); + } else { + escape_list = ECL_T; + } + goto NEXT; + } + if (a == cat_whitespace || a == cat_terminating) { + ecl_unread_char(c, in); + break; + } + unlikely_if (ecl_invalid_character_p(c)) { + FEreader_error("Found invalid character ~:C", in, 1, ECL_CODE_CHAR(c)); - } - if (read_case != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - upcase++; - count++; - if (read_case == ecl_case_downcase) - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c)) { - upcase--; - count++; - if (read_case == ecl_case_upcase) - c = ecl_char_upcase(c); - } - } - ecl_string_push_extend(token, c); - length++; - NEXT: - c = ecl_read_char(in); - if (c == EOF) - break; - a = ecl_readtable_get(rtbl, c, NULL); - } + } + if (read_case != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + upcase++; + count++; + if (read_case == ecl_case_downcase) + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c)) { + upcase--; + count++; + if (read_case == ecl_case_upcase) + c = ecl_char_upcase(c); + } + } + ecl_string_push_extend(token, c); + length++; + NEXT: + c = ecl_read_char(in); + if (c == EOF) + break; + a = ecl_readtable_get(rtbl, c, NULL); + } - if (suppress) { - x = ECL_NIL; - goto OUTPUT; - } + if (suppress) { + x = ECL_NIL; + goto OUTPUT; + } - /* If there are some escaped characters, it must be a symbol */ - if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || + /* If there are some escaped characters, it must be a symbol */ + if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || escape_list != ECL_NIL || length == 0) - goto SYMBOL; + goto SYMBOL; - /* The case in which the buffer is full of dots has to be especial cased */ - if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { - if (flags == ECL_READ_LIST_DOT) { - x = @'si::.'; - goto OUTPUT; - } else { - FEreader_error("Dots appeared illegally.", in, 0); - } - } else { - int i; - for (i = 0; i < length; i++) { - if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) - goto MAYBE_NUMBER; - } - FEreader_error("Dots appeared illegally.", in, 0); - } + /* The case in which the buffer is full of dots has to be especial cased */ + if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { + if (flags == ECL_READ_LIST_DOT) { + x = @'si::.'; + goto OUTPUT; + } else { + FEreader_error("Dots appeared illegally.", in, 0); + } + } else { + int i; + for (i = 0; i < length; i++) { + if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) + goto MAYBE_NUMBER; + } + FEreader_error("Dots appeared illegally.", in, 0); + } MAYBE_NUMBER: - /* Here we try to parse a number from the content of the buffer */ - base = ecl_current_read_base(); - if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) - goto SYMBOL; - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); - unlikely_if (x == ECL_NIL) - FEreader_error("Syntax error when reading number.~%Offending string: ~S.", - in, 1, token); - if (x != OBJNULL && length == i) - goto OUTPUT; + /* Here we try to parse a number from the content of the buffer */ + base = ecl_current_read_base(); + if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) + goto SYMBOL; + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); + unlikely_if (x == ECL_NIL) + FEreader_error("Syntax error when reading number.~%Offending string: ~S.", + in, 1, token); + if (x != OBJNULL && length == i) + goto OUTPUT; SYMBOL: - /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (flags == ECL_READ_ONLY_TOKEN) { + /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); + } + } + if (flags == ECL_READ_ONLY_TOKEN) { the_env->nvalues = 1; - return token; - } else if (external_symbol) { - x = ecl_find_symbol(token, p, &intern_flag); - unlikely_if (intern_flag != ECL_EXTERNAL) { - FEerror("Cannot find the external symbol ~A in ~S.", - 2, cl_copy_seq(token), p); - } - } else { - if (p == ECL_NIL) { - p = ecl_current_package(); - } - /* INV: cl_make_symbol() copies the string */ - x = ecl_intern(token, p, &intern_flag); - } + return token; + } else if (external_symbol) { + x = ecl_find_symbol(token, p, &intern_flag); + unlikely_if (intern_flag != ECL_EXTERNAL) { + FEerror("Cannot find the external symbol ~A in ~S.", + 2, cl_copy_seq(token), p); + } + } else { + if (p == ECL_NIL) { + p = ecl_current_package(); + } + /* INV: cl_make_symbol() copies the string */ + x = ecl_intern(token, p, &intern_flag); + } OUTPUT: - si_put_buffer_string(token); + si_put_buffer_string(token); the_env->nvalues = 1; - return x; + return x; } /* - ecl_read_object(in) reads an object from stream in. - This routine corresponds to COMMON Lisp function READ. + ecl_read_object(in) reads an object from stream in. + This routine corresponds to COMMON Lisp function READ. */ cl_object ecl_read_object(cl_object in) { - return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); + return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); } cl_object si_read_object_or_ignore(cl_object in, cl_object eof) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); x = ecl_read_object_with_delimiter(in, EOF, ECL_READ_RETURN_IGNORABLE, cat_constituent); if (x == OBJNULL) { env->nvalues = 1; x = eof; } else if (env->nvalues) { - x = patch_sharp(env, x); + x = patch_sharp(env, x); } - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_unwind_n(env, 2); + return x; } static cl_object right_parenthesis_reader(cl_object in, cl_object character) { - FEreader_error("Unmatched right parenthesis, #\\)", in, 0); + FEreader_error("Unmatched right parenthesis, #\\)", in, 0); } static cl_object left_parenthesis_reader(cl_object in, cl_object character) { - const char c = ')'; - @(return do_read_delimited_list(c, in, 0)) + const char c = ')'; + @(return do_read_delimited_list(c, in, 0)) } /* @@ -450,254 +450,254 @@ left_parenthesis_reader(cl_object in, cl_object character) static cl_object comma_reader(cl_object in, cl_object c) { - cl_object x, y; - const cl_env_ptr env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); + cl_object x, y; + const cl_env_ptr env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); - unlikely_if (backq_level <= 0) - FEreader_error("A comma has appeared out of a backquote.", in, 0); - /* Read character & complain at EOF */ - c = cl_peek_char(2,ECL_NIL,in); - if (c == ECL_CODE_CHAR('@@')) { - x = @'si::unquote-splice'; - ecl_read_char(in); - } else if (c == ECL_CODE_CHAR('.')) { - x = @'si::unquote-nsplice'; - ecl_read_char(in); - } else { - x = @'si::unquote'; - } - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); - y = ecl_read_object(in); - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - return cl_list(2, x, y); + unlikely_if (backq_level <= 0) + FEreader_error("A comma has appeared out of a backquote.", in, 0); + /* Read character & complain at EOF */ + c = cl_peek_char(2,ECL_NIL,in); + if (c == ECL_CODE_CHAR('@@')) { + x = @'si::unquote-splice'; + ecl_read_char(in); + } else if (c == ECL_CODE_CHAR('.')) { + x = @'si::unquote-nsplice'; + ecl_read_char(in); + } else { + x = @'si::unquote'; + } + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); + y = ecl_read_object(in); + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + return cl_list(2, x, y); } static cl_object backquote_reader(cl_object in, cl_object c) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); - in = ecl_read_object(in); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); + in = ecl_read_object(in); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); #if 0 - @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL)); + @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL)); #else - @(return cl_list(2,@'si::quasiquote',in)) + @(return cl_list(2,@'si::quasiquote',in)) #endif } /* - read_constituent(in) reads a sequence of constituent characters from - stream in and places it in token. As a help, it returns TRUE - or FALSE depending on the value of *READ-SUPPRESS*. + read_constituent(in) reads a sequence of constituent characters from + stream in and places it in token. As a help, it returns TRUE + or FALSE depending on the value of *READ-SUPPRESS*. */ static cl_object read_constituent(cl_object in) { - int store = !read_suppress; - cl_object rtbl = ecl_current_readtable(); - bool not_first = 0; - cl_object token = si_get_buffer_string(); - do { - int c = ecl_read_char(in); - enum ecl_chattrib c_cat; - if (c == EOF) { - break; - } - c_cat = ecl_readtable_get(rtbl, c, NULL); - if (c_cat == cat_constituent || - ((c_cat == cat_non_terminating) && not_first)) - { - if (store) { - ecl_string_push_extend(token, c); - } - } else { - ecl_unread_char(c, in); - break; - } - not_first = 1; - } while(1); - return (read_suppress)? ECL_NIL : token; + int store = !read_suppress; + cl_object rtbl = ecl_current_readtable(); + bool not_first = 0; + cl_object token = si_get_buffer_string(); + do { + int c = ecl_read_char(in); + enum ecl_chattrib c_cat; + if (c == EOF) { + break; + } + c_cat = ecl_readtable_get(rtbl, c, NULL); + if (c_cat == cat_constituent || + ((c_cat == cat_non_terminating) && not_first)) + { + if (store) { + ecl_string_push_extend(token, c); + } + } else { + ecl_unread_char(c, in); + break; + } + not_first = 1; + } while(1); + return (read_suppress)? ECL_NIL : token; } static cl_object double_quote_reader(cl_object in, cl_object c) { - int delim = ECL_CHAR_CODE(c); - cl_object rtbl = ecl_current_readtable(); - cl_object token = si_get_buffer_string(); - cl_object output; - for (;;) { - int c = ecl_read_char_noeof(in); - if (c == delim) - break; - else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) - c = ecl_read_char_noeof(in); - ecl_string_push_extend(token, c); - } + int delim = ECL_CHAR_CODE(c); + cl_object rtbl = ecl_current_readtable(); + cl_object token = si_get_buffer_string(); + cl_object output; + for (;;) { + int c = ecl_read_char_noeof(in); + if (c == delim) + break; + else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) + c = ecl_read_char_noeof(in); + ecl_string_push_extend(token, c); + } - /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see - * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ - output = cl_copy_seq(token); - si_put_buffer_string(token); - @(return output) + /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see + * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ + output = cl_copy_seq(token); + si_put_buffer_string(token); + @(return output) } static cl_object dispatch_reader_fun(cl_object in, cl_object dc) { - cl_object readtable = ecl_current_readtable(); - cl_object dispatch_table; - int c = ecl_char_code(dc); - ecl_readtable_get(readtable, c, &dispatch_table); - unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) - FEreader_error("~C is not a dispatching macro character", - in, 1, dc); - return dispatch_macro_character(dispatch_table, in, c); + cl_object readtable = ecl_current_readtable(); + cl_object dispatch_table; + int c = ecl_char_code(dc); + ecl_readtable_get(readtable, c, &dispatch_table); + unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) + FEreader_error("~C is not a dispatching macro character", + in, 1, dc); + return dispatch_macro_character(dispatch_table, in, c); } static cl_object dispatch_macro_character(cl_object table, cl_object in, int c) { - cl_object arg; - int d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - if (d >= 0) { - cl_fixnum i = 0; - do { - i = 10*i + d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - } while (d >= 0); - arg = ecl_make_fixnum(i); - } else { - arg = ECL_NIL; - } - { - cl_object dc = ECL_CODE_CHAR(c); - cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); - unlikely_if (Null(fun)) { - FEreader_error("No dispatch function defined " - "for character ~S", - in, 1, dc); - } - return _ecl_funcall4(fun, in, dc, arg); - } + cl_object arg; + int d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + if (d >= 0) { + cl_fixnum i = 0; + do { + i = 10*i + d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + } while (d >= 0); + arg = ecl_make_fixnum(i); + } else { + arg = ECL_NIL; + } + { + cl_object dc = ECL_CODE_CHAR(c); + cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); + unlikely_if (Null(fun)) { + FEreader_error("No dispatch function defined " + "for character ~S", + in, 1, dc); + } + return _ecl_funcall4(fun, in, dc, arg); + } } static cl_object single_quote_reader(cl_object in, cl_object c) { - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - @(return cl_list(2, @'quote', c)) + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + @(return cl_list(2, @'quote', c)) } static cl_object void_reader(cl_object in, cl_object c) { - /* no result */ - @(return) + /* no result */ + @(return) } static cl_object semicolon_reader(cl_object in, cl_object c) { - int auxc; + int auxc; - do - auxc = ecl_read_char(in); - while (auxc != '\n' && auxc != EOF); - /* no result */ - @(return) + do + auxc = ecl_read_char(in); + while (auxc != '\n' && auxc != EOF); + /* no result */ + @(return) } /* - sharpmacro routines + sharpmacro routines */ static cl_object sharp_C_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x, real, imag; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x, real, imag; - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) - FEreader_error("Reader macro #C should be followed by a list", - in, 0); - real = CAR(x); - imag = CADR(x); - /* INV: ecl_make_complex() checks its types. When reading circular - structures, we cannot check the types of the elements, and we - must build the complex number by hand. */ - if ((CONSP(real) || CONSP(imag)) && - !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) - { - x = ecl_alloc_object(t_complex); - x->complex.real = real; - x->complex.imag = imag; - } else { - x = ecl_make_complex(real, imag); - } - @(return x) + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) + FEend_of_file(in); + if (read_suppress) + @(return ECL_NIL); + unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) + FEreader_error("Reader macro #C should be followed by a list", + in, 0); + real = CAR(x); + imag = CADR(x); + /* INV: ecl_make_complex() checks its types. When reading circular + structures, we cannot check the types of the elements, and we + must build the complex number by hand. */ + if ((CONSP(real) || CONSP(imag)) && + !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) + { + x = ecl_alloc_object(t_complex); + x->complex.real = real; + x->complex.imag = imag; + } else { + x = ecl_make_complex(real, imag); + } + @(return x) } static cl_object sharp_backslash_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object token; - if (d != ECL_NIL && !read_suppress) { - unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { - FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); + const cl_env_ptr the_env = ecl_process_env(); + cl_object token; + if (d != ECL_NIL && !read_suppress) { + unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { + FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); } } - token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, + token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, cat_single_escape); - if (token == ECL_NIL) { - c = ECL_NIL; - } else if (TOKEN_STRING_FILLP(token) == 1) { - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); - } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { - /* #\^x */ - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); - } else { - cl_object nc = cl_name_char(token); - unlikely_if (Null(nc)) { - FEreader_error("~S is an illegal character name.", in, 1, token); - } - c = nc; - } - si_put_buffer_string(token); - ecl_return1(the_env, c); + if (token == ECL_NIL) { + c = ECL_NIL; + } else if (TOKEN_STRING_FILLP(token) == 1) { + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); + } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { + /* #\^x */ + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); + } else { + cl_object nc = cl_name_char(token); + unlikely_if (Null(nc)) { + FEreader_error("~S is an illegal character name.", in, 1, token); + } + c = nc; + } + si_put_buffer_string(token); + ecl_return1(the_env, c); } static cl_object sharp_single_quote_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if(d != ECL_NIL && !suppress) - extra_argument('\'', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) { - FEend_of_file(in); - } else if (suppress) { - c = ECL_NIL; - } else { - c = cl_list(2, @'function', c); - } - @(return c) + bool suppress = read_suppress; + if(d != ECL_NIL && !suppress) + extra_argument('\'', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) { + FEend_of_file(in); + } else if (suppress) { + c = ECL_NIL; + } else { + c = cl_list(2, @'function', c); + } + @(return c) } static cl_object @@ -706,28 +706,28 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) cl_index i; cl_object x, rv, nth, lex; - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) { - FEend_of_file(in); + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) { + FEend_of_file(in); } - if (read_suppress) { - @(return ECL_NIL); + if (read_suppress) { + @(return ECL_NIL); } - unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { - FEreader_error("Reader macro #Y should be followed by a list", - in, 0); + unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { + FEreader_error("Reader macro #Y should be followed by a list", + in, 0); } - if (ecl_length(x) == 2) { - rv = ecl_alloc_object(t_bclosure); - rv->bclosure.code = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bclosure.lex = ECL_CONS_CAR(x); + if (ecl_length(x) == 2) { + rv = ecl_alloc_object(t_bclosure); + rv->bclosure.code = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bclosure.lex = ECL_CONS_CAR(x); rv->bclosure.entry = _ecl_bclosure_dispatch_vararg; - @(return rv); - } + @(return rv); + } rv = ecl_alloc_object(t_bytecodes); @@ -770,312 +770,312 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) @(return rv); } -#define QUOTE 1 -#define EVAL 2 -#define LIST 3 -#define LISTX 4 -#define APPEND 5 -#define NCONC 6 +#define QUOTE 1 +#define EVAL 2 +#define LIST 3 +#define LISTX 4 +#define APPEND 5 +#define NCONC 6 /* *---------------------------------------------------------------------- - * Stack of unknown size + * Stack of unknown size *---------------------------------------------------------------------- */ cl_object si_make_backq_vector(cl_object d, cl_object data, cl_object in) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v, last; - cl_index dim, i; - if (Null(d)) { - dim = ecl_length(data); - } else { - dim = ecl_fixnum(d); - } - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL; i < dim; i++) { - if (data == ECL_NIL) { - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - break; - } - ecl_aset_unsafe(v, i, last = ecl_car(data)); - data = ECL_CONS_CDR(data); - } - unlikely_if (data != ECL_NIL) { - if (in != ECL_NIL) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } else { - FEerror("Vector larger than specified length, ~D", 1, d); - } - } - ecl_return1(the_env, v); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v, last; + cl_index dim, i; + if (Null(d)) { + dim = ecl_length(data); + } else { + dim = ecl_fixnum(d); + } + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL; i < dim; i++) { + if (data == ECL_NIL) { + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + break; + } + ecl_aset_unsafe(v, i, last = ecl_car(data)); + data = ECL_CONS_CDR(data); + } + unlikely_if (data != ECL_NIL) { + if (in != ECL_NIL) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } else { + FEerror("Vector larger than specified length, ~D", 1, d); + } + } + ecl_return1(the_env, v); } static cl_object sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) { - extern int _cl_backq_car(cl_object *); - const cl_env_ptr the_env = ecl_process_env(); - cl_object v; - unlikely_if (!Null(d) && - (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || - ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) - { - FEreader_error("Invalid dimension size ~D in #()", in, 1, d); - } - if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { - /* First case: ther might be unquoted elements in the vector. - * Then we just create a form that generates the vector. - */ - cl_object x = do_read_delimited_list(')', in, 1); - cl_index a = _cl_backq_car(&x); - if (a != QUOTE) { - v = cl_list(2, @'si::unquote', - cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); - } else { - return si_make_backq_vector(d, x, in); - } - } else if (read_suppress) { - /* Second case: *read-suppress* = t, we ignore the data */ - do_read_delimited_list(')', in, 1); - v = ECL_NIL; - } else if (Null(d)) { - /* Third case: no dimension provided. Read a list and - coerce it to vector. */ - return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); - } else { - /* Finally: Both dimension and data are provided. The - amount of data cannot exceed the length, but it may - be smaller, and in that case...*/ - cl_object last; - cl_index dim = ecl_fixnum(d), i; - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL;; i++) { - cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, + extern int _cl_backq_car(cl_object *); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v; + unlikely_if (!Null(d) && + (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || + ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) + { + FEreader_error("Invalid dimension size ~D in #()", in, 1, d); + } + if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { + /* First case: ther might be unquoted elements in the vector. + * Then we just create a form that generates the vector. + */ + cl_object x = do_read_delimited_list(')', in, 1); + cl_index a = _cl_backq_car(&x); + if (a != QUOTE) { + v = cl_list(2, @'si::unquote', + cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); + } else { + return si_make_backq_vector(d, x, in); + } + } else if (read_suppress) { + /* Second case: *read-suppress* = t, we ignore the data */ + do_read_delimited_list(')', in, 1); + v = ECL_NIL; + } else if (Null(d)) { + /* Third case: no dimension provided. Read a list and + coerce it to vector. */ + return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); + } else { + /* Finally: Both dimension and data are provided. The + amount of data cannot exceed the length, but it may + be smaller, and in that case...*/ + cl_object last; + cl_index dim = ecl_fixnum(d), i; + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL;; i++) { + cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, cat_constituent); - if (aux == OBJNULL) - break; - unlikely_if (i >= dim) { - FEreader_error("Vector larger than specified length," + if (aux == OBJNULL) + break; + unlikely_if (i >= dim) { + FEreader_error("Vector larger than specified length," "~D.", in, 1, d); - } - ecl_aset_unsafe(v, i, last = aux); - } - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - } - @(return v) + } + ecl_aset_unsafe(v, i, last = aux); + } + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + } + @(return v) } static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { - cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); - cl_object last, elt, x; - cl_index dim, dimcount, i; - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; + cl_env_ptr env = ecl_process_env(); + cl_index sp = ECL_STACK_INDEX(env); + cl_object last, elt, x; + cl_index dim, dimcount, i; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; - if (read_suppress) { - read_constituent(in); - @(return ECL_NIL) - } - for (dimcount = 0 ;; dimcount++) { - int x = ecl_read_char(in); - if (x == EOF) - break; - a = ecl_readtable_get(rtbl, x, NULL); - if (a == cat_terminating || a == cat_whitespace) { - ecl_unread_char(x, in); - break; - } - unlikely_if (a == cat_single_escape || a == cat_multiple_escape || + if (read_suppress) { + read_constituent(in); + @(return ECL_NIL) + } + for (dimcount = 0 ;; dimcount++) { + int x = ecl_read_char(in); + if (x == EOF) + break; + a = ecl_readtable_get(rtbl, x, NULL); + if (a == cat_terminating || a == cat_whitespace) { + ecl_unread_char(x, in); + break; + } + unlikely_if (a == cat_single_escape || a == cat_multiple_escape || (x != '0' && x != '1')) - { - FEreader_error("Character ~:C is not allowed after #*", - in, 1, ECL_CODE_CHAR(x)); - } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); - } - if (Null(d)) { - dim = dimcount; - } else { + { + FEreader_error("Character ~:C is not allowed after #*", + in, 1, ECL_CODE_CHAR(x)); + } + ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + } + if (Null(d)) { + dim = dimcount; + } else { unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || (dim > ECL_ARRAY_DIMENSION_LIMIT)) { FEreader_error("Wrong vector dimension size ~D in #*.", in, 1, d); } - unlikely_if (dimcount > dim) - FEreader_error("Too many elements in #*.", in, 0); - unlikely_if (dim && (dimcount == 0)) - FEreader_error("Cannot fill the bit-vector #*.", in, 0); - } - last = ECL_STACK_REF(env,-1); - x = ecl_alloc_simple_vector(dim, ecl_aet_bit); - for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->stack[sp+i] : last; - if (elt == ecl_make_fixnum(0)) - x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); - else - x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; - } - ECL_STACK_POP_N_UNSAFE(env, dimcount); - @(return x) + unlikely_if (dimcount > dim) + FEreader_error("Too many elements in #*.", in, 0); + unlikely_if (dim && (dimcount == 0)) + FEreader_error("Cannot fill the bit-vector #*.", in, 0); + } + last = ECL_STACK_REF(env,-1); + x = ecl_alloc_simple_vector(dim, ecl_aet_bit); + for (i = 0; i < dim; i++) { + elt = (i < dimcount) ? env->stack[sp+i] : last; + if (elt == ecl_make_fixnum(0)) + x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); + else + x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; + } + ECL_STACK_POP_N_UNSAFE(env, dimcount); + @(return x) } static cl_object sharp_colon_reader(cl_object in, cl_object ch, cl_object d) { - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - bool escape_flag; - int c; - cl_object output, token; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + bool escape_flag; + int c; + cl_object output, token; - if (d != ECL_NIL && !read_suppress) - extra_argument(':', in, d); - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - escape_flag = FALSE; - token = si_get_buffer_string(); - goto L; - for (;;) { - ecl_string_push_extend(token, c); - K: - c = ecl_read_char(in); - if (c == EOF) - goto M; - a = ecl_readtable_get(rtbl, c, NULL); - L: - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - escape_flag = TRUE; - } else if (a == cat_multiple_escape) { - escape_flag = TRUE; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - } - goto K; - } else if (ecl_lower_case_p(c)) - c = ecl_char_upcase(c); - if (a == cat_whitespace || a == cat_terminating) - break; - } - ecl_unread_char(c, in); + if (d != ECL_NIL && !read_suppress) + extra_argument(':', in, d); + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + escape_flag = FALSE; + token = si_get_buffer_string(); + goto L; + for (;;) { + ecl_string_push_extend(token, c); + K: + c = ecl_read_char(in); + if (c == EOF) + goto M; + a = ecl_readtable_get(rtbl, c, NULL); + L: + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + escape_flag = TRUE; + } else if (a == cat_multiple_escape) { + escape_flag = TRUE; + for (;;) { + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + } + goto K; + } else if (ecl_lower_case_p(c)) + c = ecl_char_upcase(c); + if (a == cat_whitespace || a == cat_terminating) + break; + } + ecl_unread_char(c, in); M: - if (read_suppress) { - output = ECL_NIL; - } else { - output = cl_make_symbol(token); - } - si_put_buffer_string(token); - @(return output) + if (read_suppress) { + output = ECL_NIL; + } else { + output = cl_make_symbol(token); + } + si_put_buffer_string(token); + @(return output) } static cl_object sharp_dot_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr env = ecl_process_env(); - if (d != ECL_NIL && !read_suppress) - extra_argument('.', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) - FEreader_error("Cannot evaluate the form #.~A", in, 1, c); + const cl_env_ptr env = ecl_process_env(); + if (d != ECL_NIL && !read_suppress) + extra_argument('.', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + if (read_suppress) + @(return ECL_NIL); + unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) + FEreader_error("Cannot evaluate the form #.~A", in, 1, c); /* FIXME! We should do something here to ensure that the #. * only uses the #n# that have been defined */ c = patch_sharp(env, c); - c = si_eval_with_env(1, c); - @(return c) + c = si_eval_with_env(1, c); + @(return c) } static cl_object read_number(cl_object in, int radix, cl_object macro_char) { - cl_index i; - cl_object x; - cl_object token = read_constituent(in); - if (token == ECL_NIL) { - x = ECL_NIL; - } else { - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); - unlikely_if (x == OBJNULL || x == ECL_NIL || + cl_index i; + cl_object x; + cl_object token = read_constituent(in); + if (token == ECL_NIL) { + x = ECL_NIL; + } else { + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); + unlikely_if (x == OBJNULL || x == ECL_NIL || i != TOKEN_STRING_FILLP(token)) { - FEreader_error("Cannot parse the #~A readmacro.", in, 1, - macro_char); - } - unlikely_if (cl_rationalp(x) == ECL_NIL) { - FEreader_error("The float ~S appeared after the #~A readmacro.", - in, 2, x, macro_char); - } - si_put_buffer_string(token); - } - return x; + FEreader_error("Cannot parse the #~A readmacro.", in, 1, + macro_char); + } + unlikely_if (cl_rationalp(x) == ECL_NIL) { + FEreader_error("The float ~S appeared after the #~A readmacro.", + in, 2, x, macro_char); + } + si_put_buffer_string(token); + } + return x; } static cl_object sharp_B_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('B', in, d); - @(return (read_number(in, 2, ECL_CODE_CHAR('B')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('B', in, d); + @(return (read_number(in, 2, ECL_CODE_CHAR('B')))) } static cl_object sharp_O_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('O', in, d); - @(return (read_number(in, 8, ECL_CODE_CHAR('O')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('O', in, d); + @(return (read_number(in, 8, ECL_CODE_CHAR('O')))) } static cl_object sharp_X_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('X', in, d); - @(return (read_number(in, 16, ECL_CODE_CHAR('X')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('X', in, d); + @(return (read_number(in, 16, ECL_CODE_CHAR('X')))) } static cl_object sharp_R_reader(cl_object in, cl_object c, cl_object d) { - int radix; - if (read_suppress) { - radix = 10; + int radix; + if (read_suppress) { + radix = 10; } else unlikely_if (!ECL_FIXNUMP(d)) { - FEreader_error("No radix was supplied in the #R readmacro.", in, 0); + FEreader_error("No radix was supplied in the #R readmacro.", in, 0); } else { - radix = ecl_fixnum(d); - unlikely_if (radix > 36 || radix < 2) { - FEreader_error("~S is an illegal radix.", in, 1, d); + radix = ecl_fixnum(d); + unlikely_if (radix > 36 || radix < 2) { + FEreader_error("~S is an illegal radix.", in, 1, d); } - } - @(return (read_number(in, radix, ECL_CODE_CHAR('R')))) + } + @(return (read_number(in, radix, ECL_CODE_CHAR('R')))) } #define sharp_A_reader void_reader @@ -1084,128 +1084,128 @@ sharp_R_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_eq_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair, value; - cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair, value; + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - if (read_suppress) @(return); - unlikely_if (Null(d)) { - FEreader_error("The #= readmacro requires an argument.", in, 0); + if (read_suppress) @(return); + unlikely_if (Null(d)) { + FEreader_error("The #= readmacro requires an argument.", in, 0); } - unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { - FEreader_error("Duplicate definitions for #~D=.", in, 1, d); + unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { + FEreader_error("Duplicate definitions for #~D=.", in, 1, d); } pair = CONS(d, OBJNULL); - ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); - value = ecl_read_object(in); - unlikely_if (value == pair) { - FEreader_error("#~D# is defined by itself.", in, 1, d); + ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); + value = ecl_read_object(in); + unlikely_if (value == pair) { + FEreader_error("#~D# is defined by itself.", in, 1, d); } - ECL_RPLACD(pair, value); - ecl_return1(the_env, value); + ECL_RPLACD(pair, value); + ecl_return1(the_env, value); } static cl_object sharp_sharp_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair; + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair; - if (read_suppress) + if (read_suppress) ecl_return1(the_env, ECL_NIL); - unlikely_if (Null(d)) { - FEreader_error("The ## readmacro requires an argument.", in, 0); + unlikely_if (Null(d)) { + FEreader_error("The ## readmacro requires an argument.", in, 0); } - pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); - unlikely_if (pair == ECL_NIL) { + pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); + unlikely_if (pair == ECL_NIL) { FEreader_error("#~D# is undefined.", in, 1, d); } else { - cl_object value = ECL_CONS_CDR(pair); - ecl_return1(the_env, (value == OBJNULL)? pair : value); - } + cl_object value = ECL_CONS_CDR(pair); + ecl_return1(the_env, (value == OBJNULL)? pair : value); + } } static cl_object do_patch_sharp(cl_object x, cl_object table) #if 1 { - /* The hash table maintains an association as follows: - * - * [1] object -> itself - * The object has been processed by patch_sharp, us as it is. - * [2] object -> nothing - * The object has to be processed by do_patch_sharp. - * [3] (# . object) -> object - * This is the value of a #n# statement. The object migt - * or might not yet be processed by do_patch_sharp(). - */ + /* The hash table maintains an association as follows: + * + * [1] object -> itself + * The object has been processed by patch_sharp, us as it is. + * [2] object -> nothing + * The object has to be processed by do_patch_sharp. + * [3] (# . object) -> object + * This is the value of a #n# statement. The object migt + * or might not yet be processed by do_patch_sharp(). + */ AGAIN: - switch (ecl_t_of(x)) { - case t_list: { - cl_object y; + switch (ecl_t_of(x)) { + case t_list: { + cl_object y; if (Null(x)) return x; - y = ecl_gethash_safe(x, table, table); + y = ecl_gethash_safe(x, table, table); if (y == table) { - /* case [2] */ + /* case [2] */ break; - } else if (y == x) { - /* case [1] */ - return x; - } else { - /* case [3] */ - x = y; - goto AGAIN; - } - } - case t_vector: - case t_array: - case t_complex: + } else if (y == x) { + /* case [1] */ + return x; + } else { + /* case [3] */ + x = y; + goto AGAIN; + } + } + case t_vector: + case t_array: + case t_complex: case t_bclosure: case t_bytecodes: { cl_object y = ecl_gethash_safe(x, table, table); - if (y == table) { - /* case [2] */ - break; - } - /* it can only be case [1] */ + if (y == table) { + /* case [2] */ + break; + } + /* it can only be case [1] */ } - default: + default: return x; - } - /* We eagerly mark the object as processed, to avoid infinite - * recursion. */ + } + /* We eagerly mark the object as processed, to avoid infinite + * recursion. */ _ecl_sethash(x, table, x); - switch (ecl_t_of(x)) { - case t_list: + switch (ecl_t_of(x)) { + case t_list: ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } break; - } + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } case t_bclosure: { x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); @@ -1214,22 +1214,22 @@ do_patch_sharp(cl_object x, cl_object table) case t_bytecodes: { x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); break; } - default:; - } + default:; + } return x; } #else { - switch (ecl_t_of(x)) { - case t_list: + switch (ecl_t_of(x)) { + case t_list: if (Null(x)) return x; - case t_vector: - case t_array: - case t_complex: + case t_vector: + case t_array: + case t_complex: case t_bclosure: case t_bytecodes: { cl_object y = ecl_gethash_safe(x, table, table); @@ -1237,39 +1237,39 @@ do_patch_sharp(cl_object x, cl_object table) break; x = y; } - default: + default: return x; - } - switch (ecl_t_of(x)) { - case t_list: + } + switch (ecl_t_of(x)) { + case t_list: ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } break; - } + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } case t_bclosure: { x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); @@ -1278,11 +1278,11 @@ do_patch_sharp(cl_object x, cl_object table) case t_bytecodes: { x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); break; } - default:; - } + default:; + } _ecl_sethash(x, table, x); return x; } @@ -1291,21 +1291,21 @@ do_patch_sharp(cl_object x, cl_object table) static cl_object patch_sharp(const cl_env_ptr the_env, cl_object x) { - cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - if (pairs == ECL_NIL) { - return x; - } else { - cl_object table = - cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, + cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + if (pairs == ECL_NIL) { + return x; + } else { + cl_object table = + cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ + cl_core.rehash_size, cl_core.rehash_threshold); - do { - cl_object pair = ECL_CONS_CAR(pairs); - _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); - pairs = ECL_CONS_CDR(pairs); - } while (pairs != ECL_NIL); - return do_patch_sharp(x, table); - } + do { + cl_object pair = ECL_CONS_CAR(pairs); + _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); + pairs = ECL_CONS_CDR(pairs); + } while (pairs != ECL_NIL); + return do_patch_sharp(x, table); + } } #define sharp_plus_reader void_reader @@ -1317,82 +1317,82 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) static cl_object sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d) { - int c; - int level = 0; + int c; + int level = 0; - if (d != ECL_NIL && !read_suppress) - extra_argument('|', in, d); - for (;;) { - c = ecl_read_char_noeof(in); - L: - if (c == '#') { - c = ecl_read_char_noeof(in); - if (c == '|') - level++; - } else if (c == '|') { - c = ecl_read_char_noeof(in); - if (c == '#') { - if (level == 0) - break; - else - --level; - } else - goto L; - } - } - @(return) - /* no result */ + if (d != ECL_NIL && !read_suppress) + extra_argument('|', in, d); + for (;;) { + c = ecl_read_char_noeof(in); + L: + if (c == '#') { + c = ecl_read_char_noeof(in); + if (c == '|') + level++; + } else if (c == '|') { + c = ecl_read_char_noeof(in); + if (c == '#') { + if (level == 0) + break; + else + --level; + } else + goto L; + } + } + @(return) + /* no result */ } static cl_object default_dispatch_macro_fun(cl_object in, cl_object c, cl_object d) { - FEreader_error("No dispatch function defined for character ~s.", in, 1, c); + FEreader_error("No dispatch function defined for character ~s.", in, 1, c); } /* - #P" ... " returns the pathname with namestring ... . + #P" ... " returns the pathname with namestring ... . */ static cl_object sharp_P_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if (d != ECL_NIL && !suppress) - extra_argument('P', in, d); - d = ecl_read_object(in); - if (suppress) { - d = ECL_NIL; - } else { - d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); - } - @(return d) + bool suppress = read_suppress; + if (d != ECL_NIL && !suppress) + extra_argument('P', in, d); + d = ecl_read_object(in); + if (suppress) { + d = ECL_NIL; + } else { + d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); + } + @(return d) } /* - #$ fixnum returns a random-state with the fixnum - as its content. + #$ fixnum returns a random-state with the fixnum + as its content. */ static cl_object sharp_dollar_reader(cl_object in, cl_object c, cl_object d) { - cl_object rs; - if (d != ECL_NIL && !read_suppress) - extra_argument('$', in, d); - c = ecl_read_object(in); - rs = ecl_alloc_object(t_random); - rs->random.value = c; - @(return rs) + cl_object rs; + if (d != ECL_NIL && !read_suppress) + extra_argument('$', in, d); + c = ecl_read_object(in); + rs = ecl_alloc_object(t_random); + rs->random.value = c; + @(return rs) } /* - readtable routines + readtable routines */ static void ECL_INLINE assert_type_readtable(cl_object function, cl_narg narg, cl_object p) { - unlikely_if (!ECL_READTABLEP(p)) { - FEwrong_type_nth_arg(function, narg, p, @[readtable]); + unlikely_if (!ECL_READTABLEP(p)) { + FEwrong_type_nth_arg(function, narg, p, @[readtable]); } } @@ -1400,68 +1400,68 @@ assert_type_readtable(cl_object function, cl_narg narg, cl_object p) cl_object ecl_copy_readtable(cl_object from, cl_object to) { - struct ecl_readtable_entry *from_rtab, *to_rtab; - cl_index i; - size_t entry_bytes = sizeof(struct ecl_readtable_entry); - size_t total_bytes = entry_bytes * RTABSIZE; - cl_object output; + struct ecl_readtable_entry *from_rtab, *to_rtab; + cl_index i; + size_t entry_bytes = sizeof(struct ecl_readtable_entry); + size_t total_bytes = entry_bytes * RTABSIZE; + cl_object output; - assert_type_readtable(@[copy-readtable], 1, from); - /* For the sake of garbage collector and thread safety we - * create an incomplete object and only copy to the destination - * at the end in a more or less "atomic" (meaning "fast") way. - */ - output = ecl_alloc_object(t_readtable); + assert_type_readtable(@[copy-readtable], 1, from); + /* For the sake of garbage collector and thread safety we + * create an incomplete object and only copy to the destination + * at the end in a more or less "atomic" (meaning "fast") way. + */ + output = ecl_alloc_object(t_readtable); output->readtable.locked = 0; - output->readtable.table = to_rtab = (struct ecl_readtable_entry *) - ecl_alloc_align(total_bytes, entry_bytes); - from_rtab = from->readtable.table; - memcpy(to_rtab, from_rtab, total_bytes); - for (i = 0; i < RTABSIZE; i++) { - cl_object d = from_rtab[i].dispatch; - if (ECL_HASH_TABLE_P(d)) { - d = si_copy_hash_table(d); - } - to_rtab[i].dispatch = d; - } - output->readtable.read_case = from->readtable.read_case; + output->readtable.table = to_rtab = (struct ecl_readtable_entry *) + ecl_alloc_align(total_bytes, entry_bytes); + from_rtab = from->readtable.table; + memcpy(to_rtab, from_rtab, total_bytes); + for (i = 0; i < RTABSIZE; i++) { + cl_object d = from_rtab[i].dispatch; + if (ECL_HASH_TABLE_P(d)) { + d = si_copy_hash_table(d); + } + to_rtab[i].dispatch = d; + } + output->readtable.read_case = from->readtable.read_case; #ifdef ECL_UNICODE - if (!Null(from->readtable.hash)) { - output->readtable.hash = si_copy_hash_table(from->readtable.hash); - } else { - output->readtable.hash = ECL_NIL; - } + if (!Null(from->readtable.hash)) { + output->readtable.hash = si_copy_hash_table(from->readtable.hash); + } else { + output->readtable.hash = ECL_NIL; + } #endif - if (!Null(to)) { + if (!Null(to)) { assert_type_readtable(@[copy-readtable], 2, to); - to->readtable = output->readtable; - output = to; - } - return output; + to->readtable = output->readtable; + output = to; + } + return output; } cl_object ecl_current_readtable(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; - /* INV: *readtable* always has a value */ - r = ECL_SYM_VAL(the_env, @'*readtable*'); - unlikely_if (!ECL_READTABLEP(r)) { - ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); - FEerror("The value of *READTABLE*, ~S, was not a readtable.", - 1, r); - } - return r; + /* INV: *readtable* always has a value */ + r = ECL_SYM_VAL(the_env, @'*readtable*'); + unlikely_if (!ECL_READTABLEP(r)) { + ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); + FEerror("The value of *READTABLE*, ~S, was not a readtable.", + 1, r); + } + return r; } int ecl_current_read_base(void) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: *READ-BASE* always has a value */ - cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); + const cl_env_ptr the_env = ecl_process_env(); + /* INV: *READ-BASE* always has a value */ + cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); cl_fixnum b; unlikely_if (!ECL_FIXNUMP(x) || ((b = ecl_fixnum(x)) < 2) || (b > 36)) @@ -1470,355 +1470,355 @@ ecl_current_read_base(void) FEerror("The value of *READ-BASE*~& ~S~%" "is not in the range (INTEGER 2 36)", 1, x); } - return b; + return b; } char ecl_current_read_default_float_format(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x; - /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ - x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); - if (x == @'single-float' || x == @'short-float') - return 'F'; - if (x == @'double-float') - return 'D'; - if (x == @'long-float') { + /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ + x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); + if (x == @'single-float' || x == @'short-float') + return 'F'; + if (x == @'double-float') + return 'D'; + if (x == @'long-float') { #ifdef ECL_LONG_FLOAT - return 'L'; + return 'L'; #else - return 'D'; + return 'D'; #endif - } - ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); - FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" + } + ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); + FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" "is not one of (SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT)", - 1, x); + 1, x); } static cl_object stream_or_default_input(cl_object stream) { - const cl_env_ptr the_env = ecl_process_env(); - if (Null(stream)) - return ECL_SYM_VAL(the_env, @'*standard-input*'); - if (stream == ECL_T) - return ECL_SYM_VAL(the_env, @'*terminal-io*'); - return stream; + const cl_env_ptr the_env = ecl_process_env(); + if (Null(stream)) + return ECL_SYM_VAL(the_env, @'*standard-input*'); + if (stream == ECL_T) + return ECL_SYM_VAL(the_env, @'*terminal-io*'); + return stream; } @(defun read (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - cl_object x; + cl_object x; @ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - /* Skip whitespace characters, but stop at beginning of new line or token */ - if (Null(recursivep)) { - cl_object rtbl = ecl_current_readtable(); - int c = ecl_read_char(strm); - if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { - ecl_unread_char(c, strm); - } - } - @(return x) + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) + @(return eof_value) + FEend_of_file(strm); + } + /* Skip whitespace characters, but stop at beginning of new line or token */ + if (Null(recursivep)) { + cl_object rtbl = ecl_current_readtable(); + int c = ecl_read_char(strm); + if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { + ecl_unread_char(c, strm); + } + } + @(return x) @) @(defun read_preserving_whitespace - (&optional (strm ECL_NIL) - (eof_errorp ECL_T) - eof_value - recursivep) - cl_object x; + (&optional (strm ECL_NIL) + (eof_errorp ECL_T) + eof_value + recursivep) + cl_object x; @ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - @(return x) + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) + @(return eof_value) + FEend_of_file(strm); + } + @(return x) @) static cl_object do_read_delimited_list(int d, cl_object in, bool proper_list) { - int after_dot = 0; - bool suppress = read_suppress; - cl_object x, y = ECL_NIL; - cl_object *p = &y; - do { - x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, - cat_constituent); - if (x == OBJNULL) { - /* End of the list. */ - unlikely_if (after_dot == 1) { - /* Something like (1 . ) */ - FEreader_error("Object missing after a list dot", in, 0); - } - return y; - } else if (x == @'si::.') { - unlikely_if (proper_list) { - FEreader_error("A dotted list was found where a proper list was expected.", in, 0); - } - unlikely_if (p == &y) { - /* Something like (. 2) */ - FEreader_error("A dot appeared after a left parenthesis.", in, 0); - } - unlikely_if (after_dot) { - /* Something like (1 . . 2) */ - FEreader_error("Two dots appeared consecutively.", in, 0); - } - after_dot = 1; - } else if (after_dot) { - unlikely_if (after_dot++ > 1) { - /* Something like (1 . 2 3) */ - FEreader_error("Too many objects after a list dot", in, 0); - } - *p = x; - } else if (!suppress) { - *p = ecl_list1(x); - p = &ECL_CONS_CDR(*p); - } - } while (1); + int after_dot = 0; + bool suppress = read_suppress; + cl_object x, y = ECL_NIL; + cl_object *p = &y; + do { + x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, + cat_constituent); + if (x == OBJNULL) { + /* End of the list. */ + unlikely_if (after_dot == 1) { + /* Something like (1 . ) */ + FEreader_error("Object missing after a list dot", in, 0); + } + return y; + } else if (x == @'si::.') { + unlikely_if (proper_list) { + FEreader_error("A dotted list was found where a proper list was expected.", in, 0); + } + unlikely_if (p == &y) { + /* Something like (. 2) */ + FEreader_error("A dot appeared after a left parenthesis.", in, 0); + } + unlikely_if (after_dot) { + /* Something like (1 . . 2) */ + FEreader_error("Two dots appeared consecutively.", in, 0); + } + after_dot = 1; + } else if (after_dot) { + unlikely_if (after_dot++ > 1) { + /* Something like (1 . 2 3) */ + FEreader_error("Too many objects after a list dot", in, 0); + } + *p = x; + } else if (!suppress) { + *p = ecl_list1(x); + p = &ECL_CONS_CDR(*p); + } + } while (1); } @(defun read_delimited_list (d &optional (strm ECL_NIL) recursivep) - cl_object l; - int delimiter; + cl_object l; + int delimiter; @ - delimiter = ecl_char_code(d); - strm = stream_or_default_input(strm); - if (!Null(recursivep)) { - l = do_read_delimited_list(delimiter, strm, 1); - } else { - ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); - l = do_read_delimited_list(delimiter, strm, 1); - l = patch_sharp(the_env, l); - ecl_bds_unwind_n(the_env, 2); - } - @(return l) + delimiter = ecl_char_code(d); + strm = stream_or_default_input(strm); + if (!Null(recursivep)) { + l = do_read_delimited_list(delimiter, strm, 1); + } else { + ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); + l = do_read_delimited_list(delimiter, strm, 1); + l = patch_sharp(the_env, l); + ecl_bds_unwind_n(the_env, 2); + } + @(return l) @) @(defun read_line (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object token, value0, value1; + int c; + cl_object token, value0, value1; @ - strm = stream_or_default_input(strm); + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) { - value0 = _ecl_funcall2(@'gray::stream-read-line', strm); - value1 = ecl_nth_value(the_env, 1); - if (!Null(value1)) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } - goto OUTPUT; - } + value0 = _ecl_funcall2(@'gray::stream-read-line', strm); + value1 = ecl_nth_value(the_env, 1); + if (!Null(value1)) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } + goto OUTPUT; + } #endif - token = si_get_buffer_string(); - do { - c = ecl_read_char(strm); - if (c == EOF || c == '\n') - break; - ecl_string_push_extend(token, c); - } while(1); - if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } else { -#ifdef ECL_NEWLINE_IS_CRLF /* From \r\n, ignore \r */ - if (TOKEN_STRING_FILLP(token) > 0 && - TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) - TOKEN_STRING_FILLP(token)--; + token = si_get_buffer_string(); + do { + c = ecl_read_char(strm); + if (c == EOF || c == '\n') + break; + ecl_string_push_extend(token, c); + } while(1); + if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } else { +#ifdef ECL_NEWLINE_IS_CRLF /* From \r\n, ignore \r */ + if (TOKEN_STRING_FILLP(token) > 0 && + TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) + TOKEN_STRING_FILLP(token)--; #endif -#ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */ - ecl_read_char(strm); +#ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */ + ecl_read_char(strm); #endif - value0 = cl_copy_seq(token); - value1 = (c == EOF? ECL_T : ECL_NIL); - } - si_put_buffer_string(token); + value0 = cl_copy_seq(token); + value1 = (c == EOF? ECL_T : ECL_NIL); + } + si_put_buffer_string(token); OUTPUT: - @(return value0 value1) + @(return value0 value1) @) @(defun read-char (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object output; + int c; + cl_object output; @ - strm = stream_or_default_input(strm); - c = ecl_read_char(strm); - if (c != EOF) - output = ECL_CODE_CHAR(c); - else if (Null(eof_errorp)) - output = eof_value; - else - FEend_of_file(strm); - @(return output) + strm = stream_or_default_input(strm); + c = ecl_read_char(strm); + if (c != EOF) + output = ECL_CODE_CHAR(c); + else if (Null(eof_errorp)) + output = eof_value; + else + FEend_of_file(strm); + @(return output) @) @(defun unread_char (c &optional (strm ECL_NIL)) @ - /* INV: unread_char() checks the type `c' */ - strm = stream_or_default_input(strm); - ecl_unread_char(ecl_char_code(c), strm); - @(return ECL_NIL) + /* INV: unread_char() checks the type `c' */ + strm = stream_or_default_input(strm); + ecl_unread_char(ecl_char_code(c), strm); + @(return ECL_NIL) @) @(defun peek-char (&optional peek_type (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object rtbl = ecl_current_readtable(); + int c; + cl_object rtbl = ecl_current_readtable(); @ - strm = stream_or_default_input(strm); - c = ecl_peek_char(strm); - if (c != EOF && !Null(peek_type)) { - if (peek_type == ECL_T) { - do { - /* If the character is not a whitespace, output */ - if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) - break; - /* Otherwise, read the whitespace and peek the - * next character */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } else { - do { - /* If the character belongs to the given class, - * we're done. */ - if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) - break; - /* Otherwise, consume the character and - * peek the next one. */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } - } - if (c != EOF) { - eof_value = ECL_CODE_CHAR(c); - } else if (!Null(eof_errorp)) { - FEend_of_file(strm); - } - @(return eof_value) + strm = stream_or_default_input(strm); + c = ecl_peek_char(strm); + if (c != EOF && !Null(peek_type)) { + if (peek_type == ECL_T) { + do { + /* If the character is not a whitespace, output */ + if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) + break; + /* Otherwise, read the whitespace and peek the + * next character */ + ecl_read_char(strm); + c = ecl_peek_char(strm); + } while (c != EOF); + } else { + do { + /* If the character belongs to the given class, + * we're done. */ + if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) + break; + /* Otherwise, consume the character and + * peek the next one. */ + ecl_read_char(strm); + c = ecl_peek_char(strm); + } while (c != EOF); + } + } + if (c != EOF) { + eof_value = ECL_CODE_CHAR(c); + } else if (!Null(eof_errorp)) { + FEend_of_file(strm); + } + @(return eof_value) @) @(defun listen (&optional (strm ECL_NIL)) @ - strm = stream_or_default_input(strm); - @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)) + strm = stream_or_default_input(strm); + @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)) @) @(defun read_char_no_hang (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int f; + int f; @ - strm = stream_or_default_input(strm); + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - cl_object output = - _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); - if (output == @':eof') - goto END_OF_FILE; - @(return output); - } + if (!ECL_ANSI_STREAM_P(strm)) { + cl_object output = + _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); + if (output == @':eof') + goto END_OF_FILE; + @(return output); + } #endif - f = ecl_listen_stream(strm); - if (f == ECL_LISTEN_AVAILABLE) { - int c = ecl_read_char(strm); - if (c != EOF) { - @(return ECL_CODE_CHAR(c)); - } - } else if (f == ECL_LISTEN_NO_CHAR) { - @(return @'nil'); - } - /* We reach here if there was an EOF */ + f = ecl_listen_stream(strm); + if (f == ECL_LISTEN_AVAILABLE) { + int c = ecl_read_char(strm); + if (c != EOF) { + @(return ECL_CODE_CHAR(c)); + } + } else if (f == ECL_LISTEN_NO_CHAR) { + @(return @'nil'); + } + /* We reach here if there was an EOF */ END_OF_FILE: - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(strm); + if (Null(eof_errorp)) + @(return eof_value) + else + FEend_of_file(strm); @) @(defun clear_input (&optional (strm ECL_NIL)) @ - strm = stream_or_default_input(strm); - ecl_clear_input(strm); - @(return ECL_NIL) + strm = stream_or_default_input(strm); + ecl_clear_input(strm); + @(return ECL_NIL) @) @(defun read_byte (binary_input_stream &optional (eof_errorp ECL_T) eof_value) - cl_object c; + cl_object c; @ - c = ecl_read_byte(binary_input_stream); - if (c == ECL_NIL) { - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(binary_input_stream); - } - @(return c) + c = ecl_read_byte(binary_input_stream); + if (c == ECL_NIL) { + if (Null(eof_errorp)) + @(return eof_value) + else + FEend_of_file(binary_input_stream); + } + @(return c) @) @(defun read_sequence (sequence stream &key (start ecl_make_fixnum(0)) end) @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) - return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); - else + if (!ECL_ANSI_STREAM_P(stream)) + return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); + else #endif - return si_do_read_sequence(sequence, stream, start, end); + return si_do_read_sequence(sequence, stream, start, end); @) @(defun copy_readtable (&o (from ecl_current_readtable()) to) @ - if (Null(from)) { - to = ecl_copy_readtable(cl_core.standard_readtable, to); - } else { - to = ecl_copy_readtable(from, to); - } - @(return to) + if (Null(from)) { + to = ecl_copy_readtable(cl_core.standard_readtable, to); + } else { + to = ecl_copy_readtable(from, to); + } + @(return to) @) cl_object cl_readtable_case(cl_object r) { assert_type_readtable(@[readtable-case], 1, r); - switch (r->readtable.read_case) { - case ecl_case_upcase: r = @':upcase'; break; - case ecl_case_downcase: r = @':downcase'; break; - case ecl_case_invert: r = @':invert'; break; - case ecl_case_preserve: r = @':preserve'; - } - @(return r) + switch (r->readtable.read_case) { + case ecl_case_upcase: r = @':upcase'; break; + case ecl_case_downcase: r = @':downcase'; break; + case ecl_case_invert: r = @':invert'; break; + case ecl_case_preserve: r = @':preserve'; + } + @(return r) } static void error_locked_readtable(cl_object r) { cl_error(2, - make_constant_base_string("Cannot modify locked readtable ~A."), + make_constant_base_string("Cannot modify locked readtable ~A."), r); } @@ -1829,218 +1829,218 @@ si_readtable_case_set(cl_object r, cl_object mode) if (r->readtable.locked) { error_locked_readtable(r); } - if (mode == @':upcase') { - r->readtable.read_case = ecl_case_upcase; - } else if (mode == @':downcase') { - r->readtable.read_case = ecl_case_downcase; - } else if (mode == @':preserve') { - r->readtable.read_case = ecl_case_preserve; - } else if (mode == @':invert') { - r->readtable.read_case = ecl_case_invert; - } else { + if (mode == @':upcase') { + r->readtable.read_case = ecl_case_upcase; + } else if (mode == @':downcase') { + r->readtable.read_case = ecl_case_downcase; + } else if (mode == @':preserve') { + r->readtable.read_case = ecl_case_preserve; + } else if (mode == @':invert') { + r->readtable.read_case = ecl_case_invert; + } else { const char *type = "(member :upcase :downcase :preserve :invert)"; - FEwrong_type_nth_arg(@[si::readtable-case-set], 2, + FEwrong_type_nth_arg(@[si::readtable-case-set], 2, mode, ecl_read_from_cstring(type)); - } - @(return mode) + } + @(return mode) } cl_object cl_readtablep(cl_object readtable) { - @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)) + @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)) } int ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table) { - cl_object m; - enum ecl_chattrib cat; + cl_object m; + enum ecl_chattrib cat; #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - cat = cat_constituent; - m = ECL_NIL; - if (!Null(hash)) { - cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); - if (!Null(pair)) { - cat = ecl_fixnum(ECL_CONS_CAR(pair)); - m = ECL_CONS_CDR(pair); - } - } - } else + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + cat = cat_constituent; + m = ECL_NIL; + if (!Null(hash)) { + cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); + if (!Null(pair)) { + cat = ecl_fixnum(ECL_CONS_CAR(pair)); + m = ECL_CONS_CDR(pair); + } + } + } else #endif - { - m = readtable->readtable.table[c].dispatch; - cat = readtable->readtable.table[c].syntax_type; - } - if (macro_or_table) *macro_or_table = m; - return cat; + { + m = readtable->readtable.table[c].dispatch; + cat = readtable->readtable.table[c].syntax_type; + } + if (macro_or_table) *macro_or_table = m; + return cat; } void ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, - cl_object macro_or_table) + cl_object macro_or_table) { if (readtable->readtable.locked) { error_locked_readtable(readtable); } #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - if (Null(hash)) { - hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + if (Null(hash)) { + hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), cl_core.rehash_size, cl_core.rehash_threshold); - readtable->readtable.hash = hash; - } - _ecl_sethash(ECL_CODE_CHAR(c), hash, - CONS(ecl_make_fixnum(cat), macro_or_table)); - } else + readtable->readtable.hash = hash; + } + _ecl_sethash(ECL_CODE_CHAR(c), hash, + CONS(ecl_make_fixnum(cat), macro_or_table)); + } else #endif - { - readtable->readtable.table[c].dispatch = macro_or_table; - readtable->readtable.table[c].syntax_type = cat; - } + { + readtable->readtable.table[c].dispatch = macro_or_table; + readtable->readtable.table[c].syntax_type = cat; + } } bool ecl_invalid_character_p(int c) { - return (c <= 32) || (c == 127); + return (c <= 32) || (c == 127); } @(defun set_syntax_from_char (tochr fromchr - &o (tordtbl ecl_current_readtable()) - fromrdtbl) - enum ecl_chattrib cat; - cl_object dispatch; - cl_fixnum fc, tc; + &o (tordtbl ecl_current_readtable()) + fromrdtbl) + enum ecl_chattrib cat; + cl_object dispatch; + cl_fixnum fc, tc; @ if (tordtbl->readtable.locked) { error_locked_readtable(tordtbl); } - if (Null(fromrdtbl)) - fromrdtbl = cl_core.standard_readtable; + if (Null(fromrdtbl)) + fromrdtbl = cl_core.standard_readtable; assert_type_readtable(@[readtable-case], 1, tordtbl); assert_type_readtable(@[readtable-case], 2, fromrdtbl); - fc = ecl_char_code(fromchr); - tc = ecl_char_code(tochr); + fc = ecl_char_code(fromchr); + tc = ecl_char_code(tochr); - cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); - if (ECL_READTABLEP(dispatch)) { - dispatch = si_copy_hash_table(dispatch); - } - ecl_readtable_set(tordtbl, tc, cat, dispatch); - @(return ECL_T) + cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); + if (ECL_READTABLEP(dispatch)) { + dispatch = si_copy_hash_table(dispatch); + } + ecl_readtable_set(tordtbl, tc, cat, dispatch); + @(return ECL_T) @) @(defun set_macro_character (c function &optional non_terminating_p - (readtable ecl_current_readtable())) + (readtable ecl_current_readtable())) @ - ecl_readtable_set(readtable, ecl_char_code(c), - Null(non_terminating_p)? - cat_terminating : - cat_non_terminating, - function); - @(return ECL_T) + ecl_readtable_set(readtable, ecl_char_code(c), + Null(non_terminating_p)? + cat_terminating : + cat_non_terminating, + function); + @(return ECL_T) @) @(defun get_macro_character (c &optional (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object dispatch; + enum ecl_chattrib cat; + cl_object dispatch; @ - if (Null(readtable)) - readtable = cl_core.standard_readtable; - cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); + if (Null(readtable)) + readtable = cl_core.standard_readtable; + cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); if (ECL_HASH_TABLE_P(dispatch)) - dispatch = cl_core.dispatch_reader; - @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)) + dispatch = cl_core.dispatch_reader; + @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)) @) @(defun make_dispatch_macro_character (chr - &optional non_terminating_p (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object table; - int c; + &optional non_terminating_p (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object table; + int c; @ assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); - c = ecl_char_code(chr); - cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; - table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + c = ecl_char_code(chr); + cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; + table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), cl_core.rehash_size, cl_core.rehash_threshold); - ecl_readtable_set(readtable, c, cat, table); - @(return ECL_T) + ecl_readtable_set(readtable, c, cat, table); + @(return ECL_T) @) @(defun set_dispatch_macro_character (dspchr subchr fnc - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum subcode; + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum subcode; @ assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); - ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); + ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); unlikely_if (readtable->readtable.locked) { error_locked_readtable(readtable); } unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - subcode = ecl_char_code(subchr); - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - if (ecl_lower_case_p(subcode)) { - subcode = ecl_char_upcase(subcode); - } else if (ecl_upper_case_p(subcode)) { - subcode = ecl_char_downcase(subcode); - } - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - @(return ECL_T) + FEerror("~S is not a dispatch character.", 1, dspchr); + } + subcode = ecl_char_code(subchr); + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + if (ecl_lower_case_p(subcode)) { + subcode = ecl_char_upcase(subcode); + } else if (ecl_upper_case_p(subcode)) { + subcode = ecl_char_downcase(subcode); + } + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + @(return ECL_T) @) @(defun get_dispatch_macro_character (dspchr subchr - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum c; + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum c; @ - if (Null(readtable)) { - readtable = cl_core.standard_readtable; - } + if (Null(readtable)) { + readtable = cl_core.standard_readtable; + } assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); - c = ecl_char_code(dspchr); - ecl_readtable_get(readtable, c, &table); - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - c = ecl_char_code(subchr); + c = ecl_char_code(dspchr); + ecl_readtable_get(readtable, c, &table); + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + c = ecl_char_code(subchr); - /* Since macro characters may take a number as argument, it is - not allowed to turn digits into dispatch macro characters */ - if (ecl_digitp(c, 10) >= 0) - @(return ECL_NIL) - @(return ecl_gethash_safe(subchr, table, ECL_NIL)) + /* Since macro characters may take a number as argument, it is + not allowed to turn digits into dispatch macro characters */ + if (ecl_digitp(c, 10) >= 0) + @(return ECL_NIL) + @(return ecl_gethash_safe(subchr, table, ECL_NIL)) @) cl_object si_standard_readtable() { - @(return cl_core.standard_readtable) + @(return cl_core.standard_readtable) } @(defun ext::readtable-lock (r &optional yesno) - cl_object output; + cl_object output; @ - assert_type_readtable(@[ext::readtable-lock], 1, r); + assert_type_readtable(@[ext::readtable-lock], 1, r); output = (r->readtable.locked)? ECL_T : ECL_NIL; - if (narg > 1) { + if (narg > 1) { r->readtable.locked = !Null(yesno); } @(return output) @@ -2049,128 +2049,128 @@ si_standard_readtable() static void extra_argument(int c, cl_object stream, cl_object d) { - FEreader_error("~S is an extra argument for the #~C readmacro.", - stream, 2, d, ECL_CODE_CHAR(c)); + FEreader_error("~S is an extra argument for the #~C readmacro.", + stream, 2, d, ECL_CODE_CHAR(c)); } -#define make_cf2(f) ecl_make_cfun((f), ECL_NIL, NULL, 2) -#define make_cf3(f) ecl_make_cfun((f), ECL_NIL, NULL, 3) +#define make_cf2(f) ecl_make_cfun((f), ECL_NIL, NULL, 2) +#define make_cf3(f) ecl_make_cfun((f), ECL_NIL, NULL, 3) void init_read(void) { - struct ecl_readtable_entry *rtab; - cl_object r; - int i; + struct ecl_readtable_entry *rtab; + cl_object r; + int i; - cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); + cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); r->readtable.locked = 0; - r->readtable.read_case = ecl_case_upcase; - r->readtable.table = rtab - = (struct ecl_readtable_entry *) - ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - rtab[i].syntax_type = cat_constituent; - rtab[i].dispatch = ECL_NIL; - } + r->readtable.read_case = ecl_case_upcase; + r->readtable.table = rtab + = (struct ecl_readtable_entry *) + ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); + for (i = 0; i < RTABSIZE; i++) { + rtab[i].syntax_type = cat_constituent; + rtab[i].dispatch = ECL_NIL; + } #ifdef ECL_UNICODE - r->readtable.hash = ECL_NIL; + r->readtable.hash = ECL_NIL; #endif - cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); + cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); - ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '"', cat_terminating, - make_cf2(double_quote_reader)); + ecl_readtable_set(r, '"', cat_terminating, + make_cf2(double_quote_reader)); - ecl_readtable_set(r, '\'', cat_terminating, - make_cf2(single_quote_reader)); - ecl_readtable_set(r, '(', cat_terminating, - make_cf2(left_parenthesis_reader)); - ecl_readtable_set(r, ')', cat_terminating, - make_cf2(right_parenthesis_reader)); - ecl_readtable_set(r, ',', cat_terminating, - make_cf2(comma_reader)); - ecl_readtable_set(r, ';', cat_terminating, - make_cf2(semicolon_reader)); - ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); - ecl_readtable_set(r, '`', cat_terminating, - make_cf2(backquote_reader)); - ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); + ecl_readtable_set(r, '\'', cat_terminating, + make_cf2(single_quote_reader)); + ecl_readtable_set(r, '(', cat_terminating, + make_cf2(left_parenthesis_reader)); + ecl_readtable_set(r, ')', cat_terminating, + make_cf2(right_parenthesis_reader)); + ecl_readtable_set(r, ',', cat_terminating, + make_cf2(comma_reader)); + ecl_readtable_set(r, ';', cat_terminating, + make_cf2(semicolon_reader)); + ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); + ecl_readtable_set(r, '`', cat_terminating, + make_cf2(backquote_reader)); + ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); - cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); + cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); - cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), - ECL_T /* non terminating */, r); + cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), + ECL_T /* non terminating */, r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), - make_cf3(sharp_C_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), - make_cf3(sharp_backslash_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), - make_cf3(sharp_single_quote_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), - make_cf3(sharp_left_parenthesis_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), - make_cf3(sharp_asterisk_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), - make_cf3(sharp_colon_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), - make_cf3(sharp_dot_reader), r); - /* Used for fasload only. */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), - make_cf3(sharp_B_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), - make_cf3(sharp_O_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), - make_cf3(sharp_X_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), - make_cf3(sharp_R_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), - @'si::sharp-a-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), - @'si::sharp-s-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), - make_cf3(sharp_P_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), + make_cf3(sharp_C_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), + make_cf3(sharp_backslash_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), + make_cf3(sharp_single_quote_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), + make_cf3(sharp_left_parenthesis_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), + make_cf3(sharp_asterisk_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), + make_cf3(sharp_colon_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), + make_cf3(sharp_dot_reader), r); + /* Used for fasload only. */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), + make_cf3(sharp_B_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), + make_cf3(sharp_O_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), + make_cf3(sharp_X_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), + make_cf3(sharp_R_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), + @'si::sharp-a-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), + @'si::sharp-s-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), + make_cf3(sharp_P_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), - make_cf3(sharp_eq_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), - make_cf3(sharp_sharp_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), - make_cf3(sharp_plus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), - make_cf3(sharp_minus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), - make_cf3(sharp_vertical_bar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), - make_cf3(sharp_dollar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), - make_cf3(sharp_Y_reader), r); - /* This is specific to this implementation: ignore BOM */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), + make_cf3(sharp_eq_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), + make_cf3(sharp_sharp_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), + make_cf3(sharp_plus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), + make_cf3(sharp_minus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), + make_cf3(sharp_vertical_bar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), + make_cf3(sharp_dollar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), + make_cf3(sharp_Y_reader), r); + /* This is specific to this implementation: ignore BOM */ #ifdef ECL_UNICODE - ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); + ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); #endif /* Lock the standard read table so that we do not have to make copies * to keep it unchanged */ r->readtable.locked = 1; - init_backq(); + init_backq(); - ECL_SET(@'*readtable*', - r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), - ECL_NIL, r); - ECL_SET(@'*read-default-float-format*', @'single-float'); + ECL_SET(@'*readtable*', + r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), + ECL_NIL, r); + ECL_SET(@'*read-default-float-format*', @'single-float'); { cl_object var, val; @@ -2198,7 +2198,7 @@ init_read(void) @'si::*print-package*', @'si::*print-structure*', @'si::*sharp-eq-context*', - @'si::*circle-counter*'); + @'si::*circle-counter*'); val = cl_list(24, /**pprint-dispatch-table**/ ECL_NIL, /**print-array**/ ECL_T, @@ -2223,7 +2223,7 @@ init_read(void) /*si::*print-package**/ cl_core.lisp_package, /*si::*print-structure**/ ECL_T, /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); + /*si::*cicle-counter**/ ECL_NIL); ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); var = cl_list(23, @'*print-pprint-dispatch*', /* See end of pprint.lsp */ @@ -2248,7 +2248,7 @@ init_read(void) @'*readtable*', @'*package*', @'si::*sharp-eq-context*', - @'si::*circle-counter*'); + @'si::*circle-counter*'); val = cl_list(23, /**pprint-dispatch-table**/ ECL_NIL, /**print-array**/ ECL_T, @@ -2272,7 +2272,7 @@ init_read(void) /**readtable**/ cl_core.standard_readtable, /**package**/ cl_core.user_package, /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); + /*si::*cicle-counter**/ ECL_NIL); ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); } } @@ -2284,7 +2284,7 @@ init_read(void) * reads the data vector from stream into vector VV * * Results: - * a vector. + * a vector. * *---------------------------------------------------------------------- */ @@ -2292,62 +2292,62 @@ static cl_object make_one_data_stream(const cl_object string) { #ifdef ECL_UNICODE - return si_make_sequence_input_stream(3, string, @':external-format', - @':utf-8'); + return si_make_sequence_input_stream(3, string, @':external-format', + @':utf-8'); #else - return ecl_make_string_input_stream(string, 0, ecl_length(string)); + return ecl_make_string_input_stream(string, 0, ecl_length(string)); #endif } static cl_object make_data_stream(const cl_object *data) { - if (data == 0 || data[0] == NULL) { - return cl_core.null_stream; - } - if (data[1] == NULL) { - return make_one_data_stream(data[0]); - } else { - cl_object stream_list = ECL_NIL; - cl_index i; - for (i = 0; data[i]; i++) { - cl_object s = make_one_data_stream(data[i]); - stream_list = ecl_cons(s, stream_list); - } - return cl_apply(2, @'make-concatenated-stream', - cl_nreverse(stream_list)); - } + if (data == 0 || data[0] == NULL) { + return cl_core.null_stream; + } + if (data[1] == NULL) { + return make_one_data_stream(data[0]); + } else { + cl_object stream_list = ECL_NIL; + cl_index i; + for (i = 0; data[i]; i++) { + cl_object s = make_one_data_stream(data[i]); + stream_list = ecl_cons(s, stream_list); + } + return cl_apply(2, @'make-concatenated-stream', + cl_nreverse(stream_list)); + } } cl_object ecl_init_module(cl_object block, void (*entry_point)(cl_object)) { - const cl_env_ptr env = ecl_process_env(); - volatile cl_object old_eptbc = env->packages_to_be_created; - volatile cl_object x; - cl_index i, len, perm_len, temp_len; - cl_object in; - cl_object *VV = NULL, *VVtemp = NULL; + const cl_env_ptr env = ecl_process_env(); + volatile cl_object old_eptbc = env->packages_to_be_created; + volatile cl_object x; + cl_index i, len, perm_len, temp_len; + cl_object in; + cl_object *VV = NULL, *VVtemp = NULL; - if (block == NULL) + if (block == NULL) block = ecl_make_codeblock(); - block->cblock.entry = entry_point; + block->cblock.entry = entry_point; - in = OBJNULL; - ECL_UNWIND_PROTECT_BEGIN(env) { + in = OBJNULL; + ECL_UNWIND_PROTECT_BEGIN(env) { cl_index bds_ndx; cl_object progv_list; - ecl_bds_bind(env, @'si::*cblock*', block); + ecl_bds_bind(env, @'si::*cblock*', block); env->packages_to_be_created_p = ECL_T; - /* Communicate the library which Cblock we are using, and get - * back the amount of data to be processed. - */ - (*entry_point)(block); - perm_len = block->cblock.data_size; - temp_len = block->cblock.temp_data_size; - len = perm_len + temp_len; + /* Communicate the library which Cblock we are using, and get + * back the amount of data to be processed. + */ + (*entry_point)(block); + perm_len = block->cblock.data_size; + temp_len = block->cblock.temp_data_size; + len = perm_len + temp_len; if (block->cblock.data_text == 0) { if (len) { @@ -2363,21 +2363,21 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object)) } goto NO_DATA_LABEL; } - if (len == 0) { + if (len == 0) { VV = VVtemp = NULL; goto NO_DATA_LABEL; } #ifdef ECL_DYNAMIC_VV - VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; + VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; #else - VV = block->cblock.data; + VV = block->cblock.data; #endif - memset(VV, 0, perm_len * sizeof(*VV)); + memset(VV, 0, perm_len * sizeof(*VV)); - VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; - memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); + VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; + memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); - /* Read all data for the library */ + /* Read all data for the library */ #ifdef ECL_EXTERNALIZABLE { cl_object v = ecl_deserialize(block->cblock.data_text); @@ -2387,50 +2387,50 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object)) memcpy(VV, v->vector.self.t, len * sizeof(cl_object)); } #else - in = make_data_stream(block->cblock.data_text); + in = make_data_stream(block->cblock.data_text); progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), ECL_CONS_CDR(progv_list)); - for (i = 0 ; i < len; i++) { - x = ecl_read_object(in); - if (x == OBJNULL) - break; - if (i < perm_len) - VV[i] = x; - else - VVtemp[i-perm_len] = x; - } - if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { - while (i--) { - if (i < perm_len) { - VV[i] = patch_sharp(env, VV[i]); - } else { - VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); - } - } - } + for (i = 0 ; i < len; i++) { + x = ecl_read_object(in); + if (x == OBJNULL) + break; + if (i < perm_len) + VV[i] = x; + else + VVtemp[i-perm_len] = x; + } + if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { + while (i--) { + if (i < perm_len) { + VV[i] = patch_sharp(env, VV[i]); + } else { + VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); + } + } + } ecl_bds_unwind(env, bds_ndx); - unlikely_if (i < len) - FEreader_error("Not enough data while loading" + unlikely_if (i < len) + FEreader_error("Not enough data while loading" "binary file", in, 0); cl_close(1,in); in = OBJNULL; #endif - NO_DATA_LABEL: + NO_DATA_LABEL: env->packages_to_be_created_p = ECL_NIL; - assert(block->cblock.cfuns_size == 0 || VV != NULL); - for (i = 0; i < block->cblock.cfuns_size; i++) { - const struct ecl_cfun *prototype = block->cblock.cfuns+i; - cl_index fname_location = ecl_fixnum(prototype->block); - cl_object fname = VV[fname_location]; - cl_index location = ecl_fixnum(prototype->name); + assert(block->cblock.cfuns_size == 0 || VV != NULL); + for (i = 0; i < block->cblock.cfuns_size; i++) { + const struct ecl_cfun *prototype = block->cblock.cfuns+i; + cl_index fname_location = ecl_fixnum(prototype->block); + cl_object fname = VV[fname_location]; + cl_index location = ecl_fixnum(prototype->name); cl_object position = prototype->file_position; - int narg = prototype->narg; - VV[location] = narg<0? - ecl_make_cfun_va((cl_objectfn)prototype->entry, + int narg = prototype->narg; + VV[location] = narg<0? + ecl_make_cfun_va((cl_objectfn)prototype->entry, fname, block) : - ecl_make_cfun((cl_objectfn_fixed)prototype->entry, + ecl_make_cfun((cl_objectfn_fixed)prototype->entry, fname, block, narg); /* Add source file info */ if (position != ecl_make_fixnum(-1)) { @@ -2438,32 +2438,32 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object)) block->cblock.source, position); } - } - /* Execute top-level code */ - (*entry_point)(OBJNULL); - x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); + } + /* Execute top-level code */ + (*entry_point)(OBJNULL); + x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); old_eptbc = env->packages_to_be_created; unlikely_if (!Null(x)) { CEerror(ECL_T, Null(ECL_CONS_CDR(x))? "Package ~A referenced in " - "compiled file~& ~A~&but has not been created": + "compiled file~& ~A~&but has not been created": "The packages~& ~A~&were referenced in " - "compiled file~& ~A~&but have not been created", - 2, x, block->cblock.name); - } - if (VVtemp) { - block->cblock.temp_data = NULL; - block->cblock.temp_data_size = 0; - ecl_dealloc(VVtemp); - } - ecl_bds_unwind1(env); - } ECL_UNWIND_PROTECT_EXIT { - if (in != OBJNULL) - cl_close(1,in); - env->packages_to_be_created = old_eptbc; + "compiled file~& ~A~&but have not been created", + 2, x, block->cblock.name); + } + if (VVtemp) { + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + ecl_dealloc(VVtemp); + } + ecl_bds_unwind1(env); + } ECL_UNWIND_PROTECT_EXIT { + if (in != OBJNULL) + cl_close(1,in); + env->packages_to_be_created = old_eptbc; env->packages_to_be_created_p = ECL_NIL; - } ECL_UNWIND_PROTECT_END; + } ECL_UNWIND_PROTECT_END; - return block; + return block; } diff --git a/src/c/reader/parse_integer.d b/src/c/reader/parse_integer.d index 8966e5ae0..b42255f0a 100644 --- a/src/c/reader/parse_integer.d +++ b/src/c/reader/parse_integer.d @@ -20,60 +20,60 @@ cl_object ecl_parse_integer(cl_object str, cl_index start, cl_index end, - cl_index *ep, unsigned int radix) + cl_index *ep, unsigned int radix) { - int sign, d; - cl_object integer_part, output; - cl_index i, c; + int sign, d; + cl_object integer_part, output; + cl_index i, c; - if (start >= end || !basep(radix)) { - *ep = start; - return OBJNULL; - } - sign = 1; - c = ecl_char(str, start); - if (c == '+') { - start++; - } else if (c == '-') { - sign = -1; - start++; - } - integer_part = _ecl_big_register0(); + if (start >= end || !basep(radix)) { + *ep = start; + return OBJNULL; + } + sign = 1; + c = ecl_char(str, start); + if (c == '+') { + start++; + } else if (c == '-') { + sign = -1; + start++; + } + integer_part = _ecl_big_register0(); _ecl_big_set_ui(integer_part, 0); - for (i = start; i < end; i++) { - c = ecl_char(str, i); - d = ecl_digitp(c, radix); - if (d < 0) { - break; - } - _ecl_big_mul_ui(integer_part, integer_part, radix); - _ecl_big_add_ui(integer_part, integer_part, d); - } - if (sign < 0) { - _ecl_big_complement(integer_part, integer_part); - } - output = _ecl_big_register_normalize(integer_part); - *ep = i; - return (i == start)? OBJNULL : output; + for (i = start; i < end; i++) { + c = ecl_char(str, i); + d = ecl_digitp(c, radix); + if (d < 0) { + break; + } + _ecl_big_mul_ui(integer_part, integer_part, radix); + _ecl_big_add_ui(integer_part, integer_part, d); + } + if (sign < 0) { + _ecl_big_complement(integer_part, integer_part); + } + output = _ecl_big_register_normalize(integer_part); + *ep = i; + return (i == start)? OBJNULL : output; } @(defun parse_integer (strng - &key (start ecl_make_fixnum(0)) - end - (radix ecl_make_fixnum(10)) - junk_allowed - &aux x) - cl_index s, e, ep; - cl_object rtbl = ecl_current_readtable(); + &key (start ecl_make_fixnum(0)) + end + (radix ecl_make_fixnum(10)) + junk_allowed + &aux x) + cl_index s, e, ep; + cl_object rtbl = ecl_current_readtable(); @ { unlikely_if (!ECL_STRINGP(strng)) { FEwrong_type_nth_arg(@[parse-integer], 1, strng, @[string]); } - unlikely_if (!ECL_FIXNUMP(radix) || + unlikely_if (!ECL_FIXNUMP(radix) || ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || ecl_fixnum_greater(radix, ecl_make_fixnum(36))) { - FEerror("~S is an illegal radix.", 1, radix); + FEerror("~S is an illegal radix.", 1, radix); } { cl_index_pair p = @@ -81,34 +81,34 @@ ecl_parse_integer(cl_object str, cl_index start, cl_index end, s = p.start; e = p.end; } - while (s < e && - ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { - s++; - } - if (s >= e) { - if (junk_allowed != ECL_NIL) - @(return ECL_NIL ecl_make_fixnum(s)) - else - goto CANNOT_PARSE; - } - x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); - if (x == OBJNULL) { - if (junk_allowed != ECL_NIL) { - @(return ECL_NIL ecl_make_fixnum(ep)); - } else { - goto CANNOT_PARSE; - } - } - if (junk_allowed != ECL_NIL) { - @(return x ecl_make_fixnum(ep)); - } - for (s = ep; s < e; s++) { - unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) + while (s < e && + ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { + s++; + } + if (s >= e) { + if (junk_allowed != ECL_NIL) + @(return ECL_NIL ecl_make_fixnum(s)) + else + goto CANNOT_PARSE; + } + x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); + if (x == OBJNULL) { + if (junk_allowed != ECL_NIL) { + @(return ECL_NIL ecl_make_fixnum(ep)); + } else { + goto CANNOT_PARSE; + } + } + if (junk_allowed != ECL_NIL) { + @(return x ecl_make_fixnum(ep)); + } + for (s = ep; s < e; s++) { + unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) != cat_whitespace) { -CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", - ECL_NIL, 1, strng); - } - } - @(return x ecl_make_fixnum(e)); +CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", + ECL_NIL, 1, strng); + } + } + @(return x ecl_make_fixnum(e)); } @) diff --git a/src/c/reader/parse_number.d b/src/c/reader/parse_number.d index 125eafed8..3b455e6cd 100644 --- a/src/c/reader/parse_number.d +++ b/src/c/reader/parse_number.d @@ -104,27 +104,27 @@ make_float(cl_object num, cl_object exp, cl_index exp_char, int sign) } /* - ecl_parse_number(str, start, end, ep, radix) parses C string str - up to (but not including) str[end] - using radix as the radix for the rational number. - (For floating numbers, the radix is ignored and replaced with 10) - When parsing succeeds, - the index of the next character is assigned to *ep, - and the number is returned as a lisp data object. - If not, OBJNULL is returned. + ecl_parse_number(str, start, end, ep, radix) parses C string str + up to (but not including) str[end] + using radix as the radix for the rational number. + (For floating numbers, the radix is ignored and replaced with 10) + When parsing succeeds, + the index of the next character is assigned to *ep, + and the number is returned as a lisp data object. + If not, OBJNULL is returned. */ cl_object ecl_parse_number(cl_object str, cl_index start, cl_index end, - cl_index *ep, unsigned int radix) + cl_index *ep, unsigned int radix) { int sign = -1, d; - cl_index c, i, decimal = end; + cl_index c, i, decimal = end; cl_object num = _ecl_big_register0(); bool some_digit = 0; - if (end <= start || radix > 36) { - *ep = start; - return OBJNULL; - } + if (end <= start || radix > 36) { + *ep = start; + return OBJNULL; + } AGAIN: _ecl_big_set_ui(num, 0); c = ecl_char(str, i = start); diff --git a/src/c/reference.d b/src/c/reference.d index b265f544a..3de285813 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -20,156 +20,156 @@ #include /* - Symbol-function returns - function-closure for function - (macro . function-closure) for macros - special for special forms. + Symbol-function returns + function-closure for function + (macro . function-closure) for macros + special for special forms. */ cl_object cl_symbol_function(cl_object sym) { - cl_object output; - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special_form) { - output = @'special'; - } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { - FEundefined_function(sym); - } else if (type & ecl_stp_macro) { - output = CONS(@'si::macro', ECL_SYM_FUN(sym)); - } else { - output = ECL_SYM_FUN(sym); - } - @(return output) + cl_object output; + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special_form) { + output = @'special'; + } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { + FEundefined_function(sym); + } else if (type & ecl_stp_macro) { + output = CONS(@'si::macro', ECL_SYM_FUN(sym)); + } else { + output = ECL_SYM_FUN(sym); + } + @(return output) } cl_object cl_fdefinition(cl_object fname) { - @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))) + @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))) } cl_object cl_fboundp(cl_object fname) { - if (Null(fname)) { - @(return ECL_NIL); - } else if (ECL_SYMBOLP(fname)) { - @(return (((fname->symbol.stype & ecl_stp_special_form) - || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)) - } else if (LISTP(fname)) { - if (CAR(fname) == @'setf') { - cl_object sym = CDR(fname); - if (CONSP(sym) && CDR(sym) == ECL_NIL) { - cl_object pair; - sym = CAR(sym); - if (ECL_SYMBOLP(sym)) { - pair = ecl_setf_definition(sym, ECL_NIL); - @(return ecl_cdr(pair)); - } - } - } - } - FEinvalid_function_name(fname); + if (Null(fname)) { + @(return ECL_NIL); + } else if (ECL_SYMBOLP(fname)) { + @(return (((fname->symbol.stype & ecl_stp_special_form) + || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)) + } else if (LISTP(fname)) { + if (CAR(fname) == @'setf') { + cl_object sym = CDR(fname); + if (CONSP(sym) && CDR(sym) == ECL_NIL) { + cl_object pair; + sym = CAR(sym); + if (ECL_SYMBOLP(sym)) { + pair = ecl_setf_definition(sym, ECL_NIL); + @(return ecl_cdr(pair)); + } + } + } + } + FEinvalid_function_name(fname); } cl_object ecl_fdefinition(cl_object fun) { - cl_type t = ecl_t_of(fun); - cl_object output; + cl_type t = ecl_t_of(fun); + cl_object output; - if (t == t_symbol) { - output = ECL_SYM_FUN(fun); - unlikely_if (output == ECL_NIL) - FEundefined_function(fun); - unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) - FEundefined_function(fun); - } else unlikely_if (Null(fun)) { - FEundefined_function(fun); - } else if (t == t_list) { - cl_object sym = CDR(fun); - unlikely_if (!CONSP(sym)) - FEinvalid_function_name(fun); - if (CAR(fun) == @'setf') { - unlikely_if (CDR(sym) != ECL_NIL) - FEinvalid_function_name(fun); - sym = CAR(sym); - unlikely_if (ecl_t_of(sym) != t_symbol) - FEinvalid_function_name(fun); - output = ecl_setf_definition(sym, ECL_NIL); - unlikely_if (Null(ecl_cdr(output))) - FEundefined_function(fun); - output = ECL_CONS_CAR(output); - } else if (CAR(fun) == @'lambda') { - return si_make_lambda(ECL_NIL, sym); - } else if (CAR(fun) == @'ext::lambda-block') { - return si_make_lambda(CAR(sym), CDR(sym)); - } else { - FEinvalid_function_name(fun); - } - } else { - FEinvalid_function_name(fun); - } - return output; + if (t == t_symbol) { + output = ECL_SYM_FUN(fun); + unlikely_if (output == ECL_NIL) + FEundefined_function(fun); + unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) + FEundefined_function(fun); + } else unlikely_if (Null(fun)) { + FEundefined_function(fun); + } else if (t == t_list) { + cl_object sym = CDR(fun); + unlikely_if (!CONSP(sym)) + FEinvalid_function_name(fun); + if (CAR(fun) == @'setf') { + unlikely_if (CDR(sym) != ECL_NIL) + FEinvalid_function_name(fun); + sym = CAR(sym); + unlikely_if (ecl_t_of(sym) != t_symbol) + FEinvalid_function_name(fun); + output = ecl_setf_definition(sym, ECL_NIL); + unlikely_if (Null(ecl_cdr(output))) + FEundefined_function(fun); + output = ECL_CONS_CAR(output); + } else if (CAR(fun) == @'lambda') { + return si_make_lambda(ECL_NIL, sym); + } else if (CAR(fun) == @'ext::lambda-block') { + return si_make_lambda(CAR(sym), CDR(sym)); + } else { + FEinvalid_function_name(fun); + } + } else { + FEinvalid_function_name(fun); + } + return output; } cl_object si_coerce_to_function(cl_object fun) { - cl_type t = ecl_t_of(fun); - if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure - || t == t_bytecodes || t == t_bclosure + cl_type t = ecl_t_of(fun); + if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure + || t == t_bytecodes || t == t_bclosure #ifdef CLOS - || (t == t_instance && fun->instance.isgf) + || (t == t_instance && fun->instance.isgf) #endif - )) { - fun = ecl_fdefinition(fun); - } - @(return fun) + )) { + fun = ecl_fdefinition(fun); + } + @(return fun) } cl_object cl_symbol_value(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object value; - if (Null(sym)) { - value = sym; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) { - FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); - } - value = ECL_SYM_VAL(the_env, sym); - if (ecl_unlikely(value == OBJNULL)) { - FEunbound_variable(sym); + const cl_env_ptr the_env = ecl_process_env(); + cl_object value; + if (Null(sym)) { + value = sym; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) { + FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); } - } - @(return value) + value = ECL_SYM_VAL(the_env, sym); + if (ecl_unlikely(value == OBJNULL)) { + FEunbound_variable(sym); + } + } + @(return value) } bool ecl_boundp(cl_env_ptr env, cl_object sym) { - if (Null(sym)) { - return 1; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) - FEwrong_type_only_arg(@[boundp], sym, @[symbol]); - return ECL_SYM_VAL(env, sym) != OBJNULL; - } + if (Null(sym)) { + return 1; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) + FEwrong_type_only_arg(@[boundp], sym, @[symbol]); + return ECL_SYM_VAL(env, sym) != OBJNULL; + } } cl_object cl_boundp(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); } cl_object cl_special_operator_p(cl_object form) { - const cl_env_ptr the_env = ecl_process_env(); - int special = ecl_symbol_type(form) & ecl_stp_special_form; - ecl_return1(the_env, special? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + int special = ecl_symbol_type(form) & ecl_stp_special_form; + ecl_return1(the_env, special? ECL_T : ECL_NIL); } diff --git a/src/c/sequence.d b/src/c/sequence.d index 8e8ffbf9b..8eb1a1e67 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -22,33 +22,33 @@ cl_index_pair ecl_sequence_start_end(cl_object fun, cl_object sequence, - cl_object start, cl_object end) + cl_object start, cl_object end) { cl_index_pair p; - cl_index l; - p.length = l = ecl_length(sequence); - unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { + cl_index l; + p.length = l = ecl_length(sequence); + unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { FEwrong_type_key_arg(fun, @[:start], start, @[unsigned-byte]); } p.start = ecl_fixnum(start); - if (Null(end)) { - p.end = l; - } else { + if (Null(end)) { + p.end = l; + } else { unlikely_if (!ECL_FIXNUMP(end) || ecl_fixnum_minusp(end)) { FEwrong_type_key_arg(fun, @[:end], end, ecl_read_from_cstring("(OR NULL UNSIGNED-BYTE)")); } - p.end = ecl_fixnum(end); - unlikely_if (p.end > l) { + p.end = ecl_fixnum(end); + unlikely_if (p.end > l) { cl_object fillp = ecl_make_fixnum(l); FEwrong_type_key_arg(fun, @[:end], end, ecl_make_integer_type(start, fillp)); } - } + } unlikely_if (p.end < p.start) { FEwrong_type_key_arg(fun, @[:start], start, ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(p.end))); + ecl_make_fixnum(p.end))); } return p; } @@ -56,225 +56,225 @@ ecl_sequence_start_end(cl_object fun, cl_object sequence, cl_object si_sequence_start_end(cl_object fun, cl_object sequence, cl_object start, cl_object end) { - cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); - @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) + cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); + @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) ecl_make_fixnum(p.length)); } cl_object cl_elt(cl_object x, cl_object i) { - @(return ecl_elt(x, ecl_to_size(i))) + @(return ecl_elt(x, ecl_to_size(i))) } cl_object ecl_elt(cl_object seq, cl_fixnum index) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { if (!LISTP(l)) goto E0; if (Null(l)) goto E; l = ECL_CONS_CDR(l); } if (!LISTP(l)) goto E0; if (Null(l)) goto E; - return ECL_CONS_CAR(l); + return ECL_CONS_CAR(l); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: + case t_vector: + case t_bitvector: + case t_base_string: if (index >= seq->vector.fillp) goto E; - return ecl_aref_unsafe(seq, index); - default: + return ecl_aref_unsafe(seq, index); + default: E0: - FEtype_error_sequence(seq); - } + FEtype_error_sequence(seq); + } E: - FEtype_error_index(seq, index); + FEtype_error_index(seq, index); } cl_object si_elt_set(cl_object seq, cl_object index, cl_object val) { - @(return ecl_elt_set(seq, ecl_to_size(index), val)) + @(return ecl_elt_set(seq, ecl_to_size(index), val)) } cl_object ecl_elt_set(cl_object seq, cl_fixnum index, cl_object val) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { if (!LISTP(l)) goto E0; if (Null(l)) goto E; l = ECL_CONS_CDR(l); } if (!LISTP(l)) goto E0; if (Null(l)) goto E; - ECL_RPLACA(l, val); - return val; + ECL_RPLACA(l, val); + return val; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: + case t_vector: + case t_bitvector: + case t_base_string: if (index >= seq->vector.fillp) goto E; - return ecl_aset_unsafe(seq, index, val); - default: + return ecl_aset_unsafe(seq, index, val); + default: E0: - FEtype_error_sequence(seq); - } + FEtype_error_sequence(seq); + } E: - FEtype_error_index(seq, index); + FEtype_error_index(seq, index); } cl_object ecl_subseq(cl_object sequence, cl_index start, cl_index limit) { - switch (ecl_t_of(sequence)) { - case t_list: - if (start) - sequence = ecl_nthcdr(start, sequence); - { - cl_object x = ECL_NIL; - cl_object *z = &x; - while (!Null(sequence) && (limit--)) { - if (ECL_ATOM(sequence)) - FEtype_error_cons(sequence); - z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); - sequence = ECL_CONS_CDR(sequence); - } - return x; - } + switch (ecl_t_of(sequence)) { + case t_list: + if (start) + sequence = ecl_nthcdr(start, sequence); + { + cl_object x = ECL_NIL; + cl_object *z = &x; + while (!Null(sequence) && (limit--)) { + if (ECL_ATOM(sequence)) + FEtype_error_cons(sequence); + z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); + sequence = ECL_CONS_CDR(sequence); + } + return x; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: { - cl_index size; - cl_object x; - if (start > sequence->vector.fillp) { - x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); - } else { - size = sequence->vector.fillp - start; - if (size > limit) - size = limit; - x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); - ecl_copy_subarray(x, 0, sequence, start, size); - } - return x; - } - default: - FEtype_error_sequence(sequence); - } + case t_vector: + case t_bitvector: + case t_base_string: { + cl_index size; + cl_object x; + if (start > sequence->vector.fillp) { + x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); + } else { + size = sequence->vector.fillp - start; + if (size > limit) + size = limit; + x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); + ecl_copy_subarray(x, 0, sequence, start, size); + } + return x; + } + default: + FEtype_error_sequence(sequence); + } } cl_object ecl_copy_seq(cl_object sequence) { - return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); + return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); } @(defun subseq (sequence start &optional end &aux x) - cl_index_pair p; + cl_index_pair p; @ - p = ecl_sequence_start_end(@[subseq], sequence, start, end); - sequence = ecl_subseq(sequence, p.start, p.end - p.start); - @(return sequence); + p = ecl_sequence_start_end(@[subseq], sequence, start, end); + sequence = ecl_subseq(sequence, p.start, p.end - p.start); + @(return sequence); @) cl_object cl_copy_seq(cl_object x) { - @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); + @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); } cl_object cl_length(cl_object x) { - @(return ecl_make_fixnum(ecl_length(x))) + @(return ecl_make_fixnum(ecl_length(x))) } cl_fixnum ecl_length(cl_object x) { - cl_fixnum i; + cl_fixnum i; - switch (ecl_t_of(x)) { - case t_list: - /* INV: A list's length always fits in a fixnum */ - i = 0; - loop_for_in(x) { - i++; - } end_loop_for_in; - return(i); + switch (ecl_t_of(x)) { + case t_list: + /* INV: A list's length always fits in a fixnum */ + i = 0; + loop_for_in(x) { + i++; + } end_loop_for_in; + return(i); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - return(x->vector.fillp); + case t_vector: + case t_base_string: + case t_bitvector: + return(x->vector.fillp); - default: - FEtype_error_sequence(x); - } + default: + FEtype_error_sequence(x); + } } cl_object cl_reverse(cl_object seq) { - cl_object output, x; + cl_object output, x; - switch (ecl_t_of(seq)) { - case t_list: { - for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { + switch (ecl_t_of(seq)) { + case t_list: { + for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { if (!LISTP(x)) goto E; - output = CONS(ECL_CONS_CAR(x), output); + output = CONS(ECL_CONS_CAR(x), output); } - break; - } + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); - ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); - ecl_reverse_subarray(output, 0, seq->vector.fillp); - break; - default: + case t_vector: + case t_bitvector: + case t_base_string: + output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); + ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); + ecl_reverse_subarray(output, 0, seq->vector.fillp); + break; + default: E: - FEtype_error_sequence(seq); - } - @(return output) + FEtype_error_sequence(seq); + } + @(return output) } cl_object cl_nreverse(cl_object seq) { - switch (ecl_t_of(seq)) { - case t_list: { - cl_object x, y, z; + switch (ecl_t_of(seq)) { + case t_list: { + cl_object x, y, z; for (x = seq, y = ECL_NIL; !Null(x); ) { if (!LISTP(x)) FEtype_error_list(x); z = x; @@ -283,19 +283,19 @@ cl_nreverse(cl_object seq) ECL_RPLACD(z, y); y = z; } - seq = y; - break; - } + seq = y; + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - ecl_reverse_subarray(seq, 0, seq->vector.fillp); - break; - default: - FEtype_error_sequence(seq); - } - @(return seq) + case t_vector: + case t_base_string: + case t_bitvector: + ecl_reverse_subarray(seq, 0, seq->vector.fillp); + break; + default: + FEtype_error_sequence(seq); + } + @(return seq) } diff --git a/src/c/serialize.d b/src/c/serialize.d index 480f7c066..e4ef68cfb 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -36,56 +36,56 @@ struct fake_symbol { static cl_index object_size[] = { 0, /* t_start */ - ROUNDED_SIZE(ecl_cons), /* t_list */ - 0, /* t_character = 2 */ - 0, /* t_fixnum = 3 */ - ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ - ROUNDED_SIZE(ecl_ratio), /* t_ratio */ - ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ - ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ + ROUNDED_SIZE(ecl_cons), /* t_list */ + 0, /* t_character = 2 */ + 0, /* t_fixnum = 3 */ + ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ + ROUNDED_SIZE(ecl_ratio), /* t_ratio */ + ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ + ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ + ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ #endif - ROUNDED_SIZE(ecl_complex), /* t_complex */ - ROUNDED_SIZE(fake_symbol), /* t_symbol */ - ROUNDED_SIZE(fake_package), /* t_package */ - ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ - ROUNDED_SIZE(ecl_array), /* t_array */ - ROUNDED_SIZE(ecl_vector), /* t_vector */ + ROUNDED_SIZE(ecl_complex), /* t_complex */ + ROUNDED_SIZE(fake_symbol), /* t_symbol */ + ROUNDED_SIZE(fake_package), /* t_package */ + ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ + ROUNDED_SIZE(ecl_array), /* t_array */ + ROUNDED_SIZE(ecl_vector), /* t_vector */ #ifdef ECL_UNICODE - ROUNDED_SIZE(ecl_string), /* t_string */ + ROUNDED_SIZE(ecl_string), /* t_string */ #endif - ROUNDED_SIZE(ecl_base_string), /* t_base_string */ - ROUNDED_SIZE(ecl_vector), /* t_bitvector */ - ROUNDED_SIZE(ecl_stream), /* t_stream */ - ROUNDED_SIZE(ecl_random), /* t_random */ - ROUNDED_SIZE(ecl_readtable), /* t_readtable */ - ROUNDED_SIZE(ecl_pathname), /* t_pathname */ - ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ - ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ - ROUNDED_SIZE(ecl_cfun), /* t_cfun */ - ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ - ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ + ROUNDED_SIZE(ecl_base_string), /* t_base_string */ + ROUNDED_SIZE(ecl_vector), /* t_bitvector */ + ROUNDED_SIZE(ecl_stream), /* t_stream */ + ROUNDED_SIZE(ecl_random), /* t_random */ + ROUNDED_SIZE(ecl_readtable), /* t_readtable */ + ROUNDED_SIZE(ecl_pathname), /* t_pathname */ + ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ + ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ + ROUNDED_SIZE(ecl_cfun), /* t_cfun */ + ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ + ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ #ifdef CLOS - ROUNDED_SIZE(ecl_instance), /* t_instance */ + ROUNDED_SIZE(ecl_instance), /* t_instance */ #else - ROUNDED_SIZE(ecl_structure), /* t_structure */ + ROUNDED_SIZE(ecl_structure), /* t_structure */ #endif /* CLOS */ #ifdef ECL_THREADS - ROUNDED_SIZE(ecl_process), /* t_process */ - ROUNDED_SIZE(ecl_lock), /* t_lock */ - ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ - ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ + ROUNDED_SIZE(ecl_process), /* t_process */ + ROUNDED_SIZE(ecl_lock), /* t_lock */ + ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ + ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ ROUNDED_SIZE(ecl_semaphore), /* t_semaphore */ ROUNDED_SIZE(ecl_barrier), /* t_barrier */ ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ #endif - ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ - ROUNDED_SIZE(ecl_foreign), /* t_foreign */ - ROUNDED_SIZE(ecl_frame), /* t_frame */ - ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ + ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ + ROUNDED_SIZE(ecl_foreign), /* t_foreign */ + ROUNDED_SIZE(ecl_frame), /* t_frame */ + ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 - , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ + , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ #endif }; @@ -105,7 +105,7 @@ alloc(pool_t pool, cl_index size) if (next_fillp >= pool->data->vector.dim) { cl_index new_dim = next_fillp + next_fillp / 2; pool->data = _ecl_funcall3(@'adjust-array', pool->data, - ecl_make_fixnum(new_dim)); + ecl_make_fixnum(new_dim)); } pool->data->vector.fillp = next_fillp; return fillp; @@ -296,23 +296,23 @@ serialize_one(pool_t pool, cl_object what) buffer->pathname.version = enqueue(pool, buffer->pathname.version); break; - case t_random: { - buffer->random.value = enqueue(pool, buffer->random.value); - break; - } - case t_bclosure: { - buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); - buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); - } - case t_bytecodes: { - buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); - buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); - buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); - buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); - buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); - buffer->bytecodes.code = serialize_bits(pool, buffer->bytecodes.code, - buffer->bytecodes.code_size); - } + case t_random: { + buffer->random.value = enqueue(pool, buffer->random.value); + break; + } + case t_bclosure: { + buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); + buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); + } + case t_bytecodes: { + buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); + buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); + buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); + buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); + buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); + buffer->bytecodes.code = serialize_bits(pool, buffer->bytecodes.code, + buffer->bytecodes.code_size); + } default: FEerror("Unable to serialize object ~A", 1, what); } @@ -375,9 +375,9 @@ reconstruct_object_ptr(uint8_t *data, cl_index bytes) static uint8_t * reconstruct_bytecodes(cl_object o, uint8_t *data) { - o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); - data += o->bytecodes.code_size; - return data; + o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); + data += o->bytecodes.code_size; + return data; } static uint8_t * @@ -450,9 +450,9 @@ reconstruct_one(uint8_t *data, cl_object *output) *output = (cl_object)data; data += ROUND_TO_WORD(sizeof(struct fake_symbol)); break; - case t_bytecodes: - data = duplicate_object(data, output); - data = reconstruct_bytecodes(*output, data); + case t_bytecodes: + data = duplicate_object(data, output); + data = reconstruct_bytecodes(*output, data); default: data = duplicate_object(data, output); } @@ -537,16 +537,16 @@ fixup(cl_object o, cl_object *o_list) case t_bclosure: o->bclosure.code = get_object(o->bclosure.code, o_list); o->bclosure.lex = get_object(o->bclosure.lex, o_list); - o->bclosure.entry = _ecl_bclosure_dispatch_vararg; + o->bclosure.entry = _ecl_bclosure_dispatch_vararg; + break; + case t_bytecodes: + o->bytecodes.name = get_object(o->bytecodes.name, o_list); + o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); + o->bytecodes.data = get_object(o->bytecodes.data, o_list); + o->bytecodes.file = get_object(o->bytecodes.file, o_list); + o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); + o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; break; - case t_bytecodes: - o->bytecodes.name = get_object(o->bytecodes.name, o_list); - o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); - o->bytecodes.data = get_object(o->bytecodes.data, o_list); - o->bytecodes.file = get_object(o->bytecodes.file, o_list); - o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); - o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - break; default: break; } diff --git a/src/c/sse2.d b/src/c/sse2.d index 3c9762f68..e4c5527f6 100644 --- a/src/c/sse2.d +++ b/src/c/sse2.d @@ -28,71 +28,71 @@ cl_object si_sse_pack_p(cl_object x) { - @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)) } /* Element type substitution */ static void verify_sse_elttype(cl_elttype eltt) { - switch (eltt) { - case ecl_aet_sf: - case ecl_aet_df: - case ecl_aet_b8: - case ecl_aet_i8: + switch (eltt) { + case ecl_aet_sf: + case ecl_aet_df: + case ecl_aet_b8: + case ecl_aet_i8: #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: + case ecl_aet_b16: + case ecl_aet_i16: #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: + case ecl_aet_b32: + case ecl_aet_i32: #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: + case ecl_aet_b64: + case ecl_aet_i64: #endif - break; /* OK */ - default: - FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); - } + break; /* OK */ + default: + FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); + } } static cl_elttype symbol_to_sse_elttype(cl_object type) { - cl_elttype eltt = ecl_symbol_to_elttype(type); - verify_sse_elttype(eltt); - return eltt; + cl_elttype eltt = ecl_symbol_to_elttype(type); + verify_sse_elttype(eltt); + return eltt; } cl_object si_sse_pack_as_elt_type(cl_object x, cl_object type) { - cl_elttype rtype; + cl_elttype rtype; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { FEwrong_type_nth_arg(@[ext::sse-pack-as-elt-type], 1, x, @[ext::sse-pack]); - } + } - rtype = symbol_to_sse_elttype(type); + rtype = symbol_to_sse_elttype(type); - if (x->sse.elttype != rtype) { - cl_object new = ecl_alloc_object(t_sse_pack); - new->sse.elttype = rtype; - new->sse.data.vi = x->sse.data.vi; - x = new; - } + if (x->sse.elttype != rtype) { + cl_object new = ecl_alloc_object(t_sse_pack); + new->sse.elttype = rtype; + new->sse.data.vi = x->sse.data.vi; + x = new; + } - @(return x) + @(return x) } cl_object si_sse_pack_element_type(cl_object x) { - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { FEwrong_type_nth_arg(@[ext::sse-pack-element-type], 1, x, @[ext::sse-pack]); - } + } - @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); + @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); } /* Conversion to and from specialized vectors */ @@ -100,42 +100,42 @@ si_sse_pack_element_type(cl_object x) cl_object si_sse_pack_to_vector(cl_object x, cl_object elt_type) { - cl_elttype etype; - cl_object vec; + cl_elttype etype; + cl_object vec; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { FEwrong_type_nth_arg(@[ext::sse-pack-to-vector], 1, x, @[ext::sse-pack]); - } + } - etype = x->sse.elttype; - if (elt_type != ECL_NIL) - etype = symbol_to_sse_elttype(elt_type); + etype = x->sse.elttype; + if (elt_type != ECL_NIL) + etype = symbol_to_sse_elttype(elt_type); - vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); - memcpy(vec->vector.self.b8, x->sse.data.b8, 16); + vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); + memcpy(vec->vector.self.b8, x->sse.data.b8, 16); - @(return vec) + @(return vec) } cl_object si_vector_to_sse_pack(cl_object x) { - cl_object ssev; + cl_object ssev; - if (ecl_unlikely(!ECL_ARRAYP(x))) { + if (ecl_unlikely(!ECL_ARRAYP(x))) { FEwrong_type_nth_arg(@[ext::vector-to-sse-pack], 1, x, @[array]); } - verify_sse_elttype(x->vector.elttype); + verify_sse_elttype(x->vector.elttype); - if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) - FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); + if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) + FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); - ssev = ecl_alloc_object(t_sse_pack); - ssev->sse.elttype = x->vector.elttype; - memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); + ssev = ecl_alloc_object(t_sse_pack); + ssev->sse.elttype = x->vector.elttype; + memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); - @(return ssev) + @(return ssev) } /* Boxing and unboxing. @@ -145,58 +145,58 @@ si_vector_to_sse_pack(cl_object x) cl_object ecl_make_int_sse_pack(__m128i value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_b8; - obj->sse.data.vi = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_b8; + obj->sse.data.vi = value; + @(return obj); } __m128i ecl_unbox_int_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vi; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vi; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_float_sse_pack(__m128 value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_sf; - obj->sse.data.vf = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_sf; + obj->sse.data.vf = value; + @(return obj); } __m128 ecl_unbox_float_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vf; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vf; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_double_sse_pack(__m128d value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_df; - obj->sse.data.vd = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_df; + obj->sse.data.vd = value; + @(return obj); } __m128d ecl_unbox_double_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vd; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vd; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } #endif // ECL_SSE2 diff --git a/src/c/stacks.d b/src/c/stacks.d index 75c921652..922d5970d 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -29,25 +29,25 @@ static void cs_set_size(cl_env_ptr env, cl_index new_size) { - volatile char foo = 0; - cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - new_size += 2*safety_area; + volatile char foo = 0; + cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + new_size += 2*safety_area; #ifdef ECL_DOWN_STACK - if (&foo > env->cs_org - new_size + 16) { - env->cs_limit = env->cs_org - new_size + 2*safety_area; - if (env->cs_limit < env->cs_barrier) - env->cs_barrier = env->cs_limit; - } + if (&foo > env->cs_org - new_size + 16) { + env->cs_limit = env->cs_org - new_size + 2*safety_area; + if (env->cs_limit < env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #else - if (&foo < env->cs_org + new_size - 16) { - env->cs_limit = env->cs_org + new_size - 2*safety_area; - if (env->cs_limit > env->cs_barrier) - env->cs_barrier = env->cs_limit; - } + if (&foo < env->cs_org + new_size - 16) { + env->cs_limit = env->cs_org + new_size - 2*safety_area; + if (env->cs_limit > env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #endif - else - ecl_internal_error("can't reset env->cs_limit."); - env->cs_size = new_size; + else + ecl_internal_error("can't reset env->cs_limit."); + env->cs_size = new_size; } void @@ -57,51 +57,51 @@ ecl_cs_overflow(void) "\n;;;\n;;; Stack overflow.\n" ";;; Jumping to the outermost toplevel prompt\n" ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cl_index size = env->cs_size; + cl_env_ptr env = ecl_process_env(); + cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cl_index size = env->cs_size; #ifdef ECL_DOWN_STACK - if (env->cs_limit > env->cs_org - size) - env->cs_limit -= safety_area; + if (env->cs_limit > env->cs_org - size) + env->cs_limit -= safety_area; #else - if (env->cs_limit < env->cs_org + size) - env->cs_limit += safety_area; + if (env->cs_limit < env->cs_org + size) + env->cs_limit += safety_area; #endif - else + else ecl_unrecoverable_error(env, stack_overflow_msg); - cl_cerror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - size += size / 2; - cs_set_size(env, size); + cl_cerror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::c-stack'); + size += size / 2; + cs_set_size(env, size); } void ecl_cs_set_org(cl_env_ptr env) { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. - */ - env->cs_org = (char*)(&env); - env->cs_barrier = env->cs_org; + /* Rough estimate. Not very safe. We assume that cl_boot() + * is invoked from the main() routine of the program. + */ + env->cs_org = (char*)(&env); + env->cs_barrier = env->cs_org; #if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK) - { - struct rlimit rl; - cl_index size; - getrlimit(RLIMIT_STACK, &rl); - if (rl.rlim_cur != RLIM_INFINITY) { - size = rl.rlim_cur / 2; - if (size > (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) - ecl_set_option(ECL_OPT_C_STACK_SIZE, size); + { + struct rlimit rl; + cl_index size; + getrlimit(RLIMIT_STACK, &rl); + if (rl.rlim_cur != RLIM_INFINITY) { + size = rl.rlim_cur / 2; + if (size > (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) + ecl_set_option(ECL_OPT_C_STACK_SIZE, size); #ifdef ECL_DOWN_STACK - env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; + env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; #else - env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; + env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; #endif - } - } + } + } #endif - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); } @@ -110,32 +110,32 @@ ecl_cs_set_org(cl_env_ptr env) void ecl_bds_unwind_n(cl_env_ptr env, int n) { - while (n--) ecl_bds_unwind1(env); + while (n--) ecl_bds_unwind1(env); } static void ecl_bds_set_size(cl_env_ptr env, cl_index size) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; - if (size <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr org; - org = ecl_alloc_atomic(size * sizeof(*org)); + ecl_bds_ptr old_org = env->bds_org; + cl_index limit = env->bds_top - old_org; + if (size <= limit) { + FEerror("Cannot shrink the binding stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_ptr org; + org = ecl_alloc_atomic(size * sizeof(*org)); - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_top = org + limit; - env->bds_org = org; - env->bds_limit = org + (size - 2*margin); - env->bds_size = size; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->bds_top = org + limit; + env->bds_org = org; + env->bds_limit = org + (size - 2*margin); + env->bds_size = size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } ecl_bds_ptr @@ -145,34 +145,34 @@ ecl_bds_overflow(void) "\n;;;\n;;; Binding stack overflow.\n" ";;; Jumping to the outermost toplevel prompt\n" ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - cl_index size = env->bds_size; - ecl_bds_ptr org = env->bds_org; - ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + cl_index size = env->bds_size; + ecl_bds_ptr org = env->bds_org; + ecl_bds_ptr last = org + size; + if (env->bds_limit >= last) { ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->bds_limit += margin; - cl_cerror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - ecl_bds_set_size(env, size + (size / 2)); + } + env->bds_limit += margin; + cl_cerror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::binding-stack'); + ecl_bds_set_size(env, size + (size / 2)); return env->bds_top; } void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) { - ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; - ecl_bds_ptr bds = env->bds_top; - for (; bds > new_bds_top; bds--) + ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; + ecl_bds_ptr bds = env->bds_top; + for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); #else - bds->symbol->symbol.value = bds->value; + bds->symbol->symbol.value = bds->value; #endif - env->bds_top = new_bds_top; + env->bds_top = new_bds_top; } cl_index @@ -201,33 +201,33 @@ ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) static ecl_bds_ptr get_bds_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); - if (env->bds_org <= p && p <= env->bds_top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); + if (env->bds_org <= p && p <= env->bds_top) + return(p); + } + FEerror("~S is an illegal bds index.", 1, x); } cl_object si_bds_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->bds_top - env->bds_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->bds_top - env->bds_org)) } cl_object si_bds_var(cl_object arg) { - @(return get_bds_ptr(arg)->symbol) + @(return get_bds_ptr(arg)->symbol) } cl_object si_bds_val(cl_object arg) { cl_object v = get_bds_ptr(arg)->value; - @(return ((v == OBJNULL)? ECL_UNBOUND : v)) + @(return ((v == OBJNULL)? ECL_UNBOUND : v)) } #ifdef ecl_bds_bind @@ -247,16 +247,16 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol) { cl_object pool; cl_index new_index = symbol->symbol.binding; - if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); - if (!Null(pool)) { - new_index = ecl_fixnum(ECL_CONS_CAR(pool)); - } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); - } - symbol->symbol.binding = new_index; - symbol->symbol.dynamic |= 1; - } + if (new_index == ECL_MISSING_SPECIAL_BINDING) { + pool = ecl_atomic_pop(&cl_core.reused_indices); + if (!Null(pool)) { + new_index = ecl_fixnum(ECL_CONS_CAR(pool)); + } else { + new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + } + symbol->symbol.binding = new_index; + symbol->symbol.dynamic |= 1; + } si_set_finalizer(symbol, ECL_T); return new_index; } @@ -309,10 +309,10 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) slot->value = *location; *location = v; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; \ - s->symbol.value = v; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; \ + s->symbol.value = v; #endif } @@ -331,19 +331,19 @@ ecl_bds_push(cl_env_ptr env, cl_object s) if (slot >= env->bds_limit) slot = ecl_bds_overflow(); slot->symbol = s; slot->value = *location; - if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; + if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; #endif } void ecl_bds_unwind1(cl_env_ptr env) { - ecl_bds_ptr slot = env->bds_top--; - cl_object s = slot->symbol; + ecl_bds_ptr slot = env->bds_top--; + cl_object s = slot->symbol; #ifdef ECL_THREADS cl_object *location = env->thread_local_bindings + s->symbol.binding; *location = slot->value; @@ -373,13 +373,13 @@ ecl_bds_ref(cl_env_ptr env, cl_object s) if (*location != ECL_NO_TL_BINDING) return location; } - return &(s->symbol.value); + return &(s->symbol.value); } cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) { - return *ecl_bds_ref(env, s) = value; + return *ecl_bds_ref(env, s) = value; } #endif /* ECL_THREADS */ @@ -388,78 +388,78 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) static cl_object ihs_function_name(cl_object x) { - cl_object y; + cl_object y; - switch (ecl_t_of(x)) { - case t_symbol: - return(x); + switch (ecl_t_of(x)) { + case t_symbol: + return(x); - case t_bclosure: - x = x->bclosure.code; + case t_bclosure: + x = x->bclosure.code; - case t_bytecodes: - y = x->bytecodes.name; - if (Null(y)) - return(@'lambda'); - else - return y; + case t_bytecodes: + y = x->bytecodes.name; + if (Null(y)) + return(@'lambda'); + else + return y; - case t_cfun: - case t_cfunfixed: - return(x->cfun.name); + case t_cfun: + case t_cfunfixed: + return(x->cfun.name); - default: - return(ECL_NIL); - } + default: + return(ECL_NIL); + } } static ecl_ihs_ptr get_ihs_ptr(cl_index n) { - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; + cl_env_ptr env = ecl_process_env(); + ecl_ihs_ptr p = env->ihs_top; + if (n > p->index) + FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); + while (n < p->index) + p = p->next; + return p; } cl_object si_ihs_top(void) { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->ihs_top->index)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->ihs_top->index)) } cl_object si_ihs_prev(cl_object x) { - @(return cl_1M(x)) + @(return cl_1M(x)) } cl_object si_ihs_next(cl_object x) { - @(return cl_1P(x)) + @(return cl_1P(x)) } cl_object si_ihs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)) + @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)) } cl_object si_ihs_fun(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->function) + @(return get_ihs_ptr(ecl_to_size(arg))->function) } cl_object si_ihs_env(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->lex_env) + @(return get_ihs_ptr(ecl_to_size(arg))->lex_env) } /********************** FRAME STACK *************************/ @@ -467,137 +467,137 @@ si_ihs_env(cl_object arg) static void frs_set_size(cl_env_ptr env, cl_index size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; - if (size <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - ecl_frame_ptr org; - size += 2*margin; - org = ecl_alloc_atomic(size * sizeof(*org)); + ecl_frame_ptr old_org = env->frs_org; + cl_index limit = env->frs_top - old_org; + if (size <= limit) { + FEerror("Cannot shrink frame stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + ecl_frame_ptr org; + size += 2*margin; + org = ecl_alloc_atomic(size * sizeof(*org)); - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->frs_top = org + limit; - env->frs_org = org; - env->frs_limit = org + (size - 2*margin); - env->frs_size = size; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->frs_top = org + limit; + env->frs_org = org; + env->frs_limit = org + (size - 2*margin); + env->frs_size = size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } static void -frs_overflow(void) /* used as condition in list.d */ +frs_overflow(void) /* used as condition in list.d */ { static const char *stack_overflow_msg = "\n;;;\n;;; Frame stack overflow.\n" ";;; Jumping to the outermost toplevel prompt\n" ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - cl_index size = env->frs_size; - ecl_frame_ptr org = env->frs_org; - ecl_frame_ptr last = org + size; - if (env->frs_limit >= last) { + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + cl_index size = env->frs_size; + ecl_frame_ptr org = env->frs_org; + ecl_frame_ptr last = org + size; + if (env->frs_limit >= last) { ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->frs_limit += margin; - cl_cerror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - frs_set_size(env, size + size / 2); + } + env->frs_limit += margin; + cl_cerror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::frame-stack'); + frs_set_size(env, size + size / 2); } ecl_frame_ptr _ecl_frs_push(register cl_env_ptr env, register cl_object val) { - ecl_frame_ptr output = ++env->frs_top; - if (output >= env->frs_limit) { - frs_overflow(); - output = env->frs_top; - } - output->frs_bds_top_index = env->bds_top - env->bds_org; - output->frs_val = val; - output->frs_ihs = env->ihs_top; - output->frs_sp = ECL_STACK_INDEX(env); - return output; + ecl_frame_ptr output = ++env->frs_top; + if (output >= env->frs_limit) { + frs_overflow(); + output = env->frs_top; + } + output->frs_bds_top_index = env->bds_top - env->bds_org; + output->frs_val = val; + output->frs_ihs = env->ihs_top; + output->frs_sp = ECL_STACK_INDEX(env); + return output; } void ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) { - env->nlj_fr = fr; - while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) - --env->frs_top; - env->ihs_top = env->frs_top->frs_ihs; - ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); - ecl_longjmp(env->frs_top->frs_jmpbuf, 1); - /* never reached */ + env->nlj_fr = fr; + while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) + --env->frs_top; + env->ihs_top = env->frs_top->frs_ihs; + ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); + ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); + ecl_longjmp(env->frs_top->frs_jmpbuf, 1); + /* never reached */ } ecl_frame_ptr frs_sch (cl_object frame_id) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) - if (top->frs_val == frame_id) - return(top); - return(NULL); + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr top; + for (top = env->frs_top; top >= env->frs_org; top--) + if (top->frs_val == frame_id) + return(top); + return(NULL); } static ecl_frame_ptr get_frame_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); - if (env->frs_org <= p && p <= env->frs_top) - return p; - } - FEerror("~S is an illegal frs index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); + if (env->frs_org <= p && p <= env->frs_top) + return p; + } + FEerror("~S is an illegal frs index.", 1, x); } cl_object si_frs_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->frs_top - env->frs_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->frs_top - env->frs_org)) } cl_object si_frs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)) } cl_object si_frs_tag(cl_object arg) { - @(return get_frame_ptr(arg)->frs_val) + @(return get_frame_ptr(arg)->frs_val) } cl_object si_frs_ihs(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)) } cl_object si_sch_frs_base(cl_object fr, cl_object ihs) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_top && x->frs_ihs->index < y; - x++); - @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))) + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr x; + cl_index y = ecl_to_size(ihs); + for (x = get_frame_ptr(fr); + x <= env->frs_top && x->frs_ihs->index < y; + x++); + @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))) } /********************* INITIALIZATION ***********************/ @@ -605,63 +605,63 @@ si_sch_frs_base(cl_object fr, cl_object ihs) cl_object si_set_limit(cl_object type, cl_object size) { - cl_env_ptr env = ecl_process_env(); - cl_index the_size = ecl_to_size(size); - if (type == @'ext::frame-stack') { - frs_set_size(env, the_size); - } else if (type == @'ext::binding-stack') { - ecl_bds_set_size(env, the_size); - } else if (type == @'ext::c-stack') { - cs_set_size(env, the_size); - } else if (type == @'ext::lisp-stack') { - ecl_stack_set_size(env, the_size); + cl_env_ptr env = ecl_process_env(); + cl_index the_size = ecl_to_size(size); + if (type == @'ext::frame-stack') { + frs_set_size(env, the_size); + } else if (type == @'ext::binding-stack') { + ecl_bds_set_size(env, the_size); + } else if (type == @'ext::c-stack') { + cs_set_size(env, the_size); + } else if (type == @'ext::lisp-stack') { + ecl_stack_set_size(env, the_size); } else { - _ecl_set_max_heap_size(the_size); - } + _ecl_set_max_heap_size(the_size); + } return si_get_limit(type); } cl_object si_get_limit(cl_object type) { - cl_env_ptr env = ecl_process_env(); - cl_index output; - if (type == @'ext::frame-stack') { - output = env->frs_size; - } else if (type == @'ext::binding-stack') { - output = env->bds_size; - } else if (type == @'ext::c-stack') { - output = env->cs_size; - } else if (type == @'ext::lisp-stack') { - output = env->stack_size; - } else { - output = cl_core.max_heap_size; - } - @(return ecl_make_unsigned_integer(output)) + cl_env_ptr env = ecl_process_env(); + cl_index output; + if (type == @'ext::frame-stack') { + output = env->frs_size; + } else if (type == @'ext::binding-stack') { + output = env->bds_size; + } else if (type == @'ext::c-stack') { + output = env->cs_size; + } else if (type == @'ext::lisp-stack') { + output = env->stack_size; + } else { + output = cl_core.max_heap_size; + } + @(return ecl_make_unsigned_integer(output)) } void init_stacks(cl_env_ptr env) { - static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; - cl_index size, margin; + static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; + cl_index size, margin; - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_size = size; - env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); - env->frs_top = env->frs_org-1; - env->frs_limit = &env->frs_org[size - 2*margin]; + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; + env->frs_size = size; + env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); + env->frs_top = env->frs_org-1; + env->frs_limit = &env->frs_org[size - 2*margin]; - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_size = size; - env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); - env->bds_top = env->bds_org-1; - env->bds_limit = &env->bds_org[size - 2*margin]; + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; + env->bds_size = size; + env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); + env->bds_top = env->bds_org-1; + env->bds_limit = &env->bds_org[size - 2*margin]; - env->ihs_top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; + env->ihs_top = &ihs_org; + ihs_org.function = ECL_NIL; + ihs_org.lex_env = ECL_NIL; + ihs_org.index = 0; } diff --git a/src/c/string.d b/src/c/string.d index 28a899cd7..ab330961b 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -26,70 +26,70 @@ typedef ecl_character (*ecl_casefun)(ecl_character, bool *); static cl_object do_make_base_string(cl_index s, ecl_base_char code) { - cl_object x = ecl_alloc_simple_base_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->base_string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_base_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->base_string.self[i] = code; + return x; } #ifdef ECL_UNICODE static cl_object do_make_string(cl_index s, ecl_character code) { - cl_object x = ecl_alloc_simple_extended_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_extended_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->string.self[i] = code; + return x; } #else #define do_make_string do_make_base_string #endif @(defun make_string (size &key (initial_element ECL_CODE_CHAR(' ')) - (element_type @'character')) - cl_index s; - cl_object x; + (element_type @'character')) + cl_index s; + cl_object x; @ - s = ecl_to_index(size); - /* INV: ecl_[base_]char_code() checks the type of initial_element() */ - if (element_type == @'base-char' || element_type == @'standard-char') { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (element_type == @'character') { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else { - FEerror("The type ~S is not a valid string char type.", - 1, element_type); - } - @(return x) + s = ecl_to_index(size); + /* INV: ecl_[base_]char_code() checks the type of initial_element() */ + if (element_type == @'base-char' || element_type == @'standard-char') { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (element_type == @'character') { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else { + FEerror("The type ~S is not a valid string char type.", + 1, element_type); + } + @(return x) @) /* - Make a string of a certain size, with some eading zeros to - keep C happy. The string must be adjustable, to allow further - growth. (See unixfsys.c for its use). + Make a string of a certain size, with some eading zeros to + keep C happy. The string must be adjustable, to allow further + growth. (See unixfsys.c for its use). */ cl_object ecl_alloc_adjustable_base_string(cl_index l) { - cl_object output = ecl_alloc_object(t_base_string); - output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); + cl_object output = ecl_alloc_object(t_base_string); + output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); output->base_string.self[l] = 0; - output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; output->base_string.elttype = ecl_aet_bc; - output->base_string.displaced = ECL_NIL; - output->base_string.dim = l; - output->base_string.fillp = 0; - return output; + output->base_string.displaced = ECL_NIL; + output->base_string.dim = l; + output->base_string.fillp = 0; + return output; } #ifdef ECL_UNICODE @@ -97,499 +97,499 @@ cl_object ecl_alloc_adjustable_extended_string(cl_index l) { cl_index bytes = sizeof(ecl_character) * l; - cl_object output = ecl_alloc_object(t_string); - output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); - output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + cl_object output = ecl_alloc_object(t_string); + output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); + output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; output->string.elttype = ecl_aet_ch; - output->string.displaced = ECL_NIL; - output->string.dim = l; + output->string.displaced = ECL_NIL; + output->string.dim = l; output->string.fillp = 0; - return output; + return output; } #endif /* - Make_simple_base_string(s) makes a simple-base string from C string s. + Make_simple_base_string(s) makes a simple-base string from C string s. */ cl_object ecl_make_simple_base_string(char *s, cl_fixnum l) { - cl_object x = ecl_alloc_object(t_base_string); + cl_object x = ecl_alloc_object(t_base_string); x->base_string.elttype = ecl_aet_bc; x->base_string.flags = 0; /* no fill pointer, no adjustable */ - x->base_string.displaced = ECL_NIL; + x->base_string.displaced = ECL_NIL; if (l < 0) l = strlen(s); - x->base_string.dim = (x->base_string.fillp = l); - x->base_string.self = (ecl_base_char *)s; - return x; + x->base_string.dim = (x->base_string.fillp = l); + x->base_string.self = (ecl_base_char *)s; + return x; } cl_object make_base_string_copy(const char *s) { - cl_object x; - cl_index l = strlen(s); + cl_object x; + cl_index l = strlen(s); - x = ecl_alloc_simple_base_string(l); - memcpy(x->base_string.self, s, l); - return x; + x = ecl_alloc_simple_base_string(l); + memcpy(x->base_string.self, s, l); + return x; } cl_object ecl_cstring_to_base_string_or_nil(const char *s) { - if (s == NULL) - return ECL_NIL; - else - return make_base_string_copy(s); + if (s == NULL) + return ECL_NIL; + else + return make_base_string_copy(s); } bool ecl_fits_in_base_string(cl_object s) { - switch (ecl_t_of(s)) { + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: { - cl_index i; - for (i = 0; i < s->string.fillp; i++) { - if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) - return 0; - } - return 1; - } + case t_string: { + cl_index i; + for (i = 0; i < s->string.fillp; i++) { + if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) + return 0; + } + return 1; + } #endif - case t_base_string: - return 1; - default: - FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); - } + case t_base_string: + return 1; + default: + FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); + } } cl_object si_copy_to_simple_base_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch(ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - x = cl_string(x); - goto AGAIN; + switch(ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + x = cl_string(x); + goto AGAIN; #ifdef ECL_UNICODE - case t_string: { - cl_index index, length = x->string.fillp; - y = ecl_alloc_simple_base_string(length); - for (index=0; index < length; index++) { - ecl_character c = x->string.self[index]; - if (!ECL_BASE_CHAR_CODE_P(c)) - FEerror("Cannot coerce string ~A to a base-string", 1, x); - y->base_string.self[index] = c; - } - break; - } + case t_string: { + cl_index index, length = x->string.fillp; + y = ecl_alloc_simple_base_string(length); + for (index=0; index < length; index++) { + ecl_character c = x->string.self[index]; + if (!ECL_BASE_CHAR_CODE_P(c)) + FEerror("Cannot coerce string ~A to a base-string", 1, x); + y->base_string.self[index] = c; + } + break; + } #endif - case t_base_string: { - cl_index length = x->base_string.fillp; - y = ecl_alloc_simple_base_string(length); - memcpy(y->base_string.self, x->base_string.self, length); - break; - } - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: + case t_base_string: { + cl_index length = x->base_string.fillp; + y = ecl_alloc_simple_base_string(length); + memcpy(y->base_string.self, x->base_string.self, length); + break; + } + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,x,@[string]); - } - @(return y) + } + @(return y) } cl_object cl_string(cl_object x) { - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - break; - case t_character: { - cl_object y; + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + break; + case t_character: { + cl_object y; ecl_character c = ECL_CHAR_CODE(x); #ifdef ECL_UNICODE - if (ECL_BASE_CHAR_CODE_P(c)) { - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - } else { - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = c; - x = y; - } + if (ECL_BASE_CHAR_CODE_P(c)) { + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + } else { + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = c; + x = y; + } #else - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - break; + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + break; #endif - } + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - break; - } - default: + case t_base_string: + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + break; + } + default: FEwrong_type_nth_arg(@[string],1,x,@[string]); - } - @(return x) + } + @(return x) } #ifdef ECL_UNICODE cl_object si_coerce_to_base_string(cl_object x) { - if (!ECL_BASE_STRING_P(x)) { - x = si_copy_to_simple_base_string(x); - } - @(return x) + if (!ECL_BASE_STRING_P(x)) { + x = si_copy_to_simple_base_string(x); + } + @(return x) } cl_object si_coerce_to_extended_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = ECL_CHAR_CODE(x); - break; - case t_base_string: { - cl_index index, len = x->base_string.dim; - y = ecl_alloc_simple_extended_string(x->base_string.fillp); - for(index=0; index < len; index++) { - y->string.self[index] = x->base_string.self[index]; - } - y->string.fillp = x->base_string.fillp; - } - case t_string: - y = x; - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = ECL_CHAR_CODE(x); + break; + case t_base_string: { + cl_index index, len = x->base_string.dim; + y = ecl_alloc_simple_extended_string(x->base_string.fillp); + for(index=0; index < len; index++) { + y->string.self[index] = x->base_string.self[index]; + } + y->string.fillp = x->base_string.fillp; + } + case t_string: + y = x; + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: FEwrong_type_nth_arg(@[si::coerce-to-extended-string],1,x,@[string]); - } - @(return y) + } + @(return y) } #endif cl_object cl_char(cl_object object, cl_object index) { - cl_index position = ecl_to_index(index); - @(return ECL_CODE_CHAR(ecl_char(object, position))) + cl_index position = ecl_to_index(index); + @(return ECL_CODE_CHAR(ecl_char(object, position))) } ecl_character ecl_char(cl_object object, cl_index index) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index]; + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index]; #endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index]; - default: + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index]; + default: FEwrong_type_nth_arg(@[char],1,object,@[string]); - } + } } cl_object si_char_set(cl_object object, cl_object index, cl_object value) { - cl_index position = ecl_to_index(index); - cl_index c = ecl_char_code(value); - ecl_char_set(object, position, c); - @(return value) + cl_index position = ecl_to_index(index); + cl_index c = ecl_char_code(value); + ecl_char_set(object, position, c); + @(return value) } ecl_character ecl_char_set(cl_object object, cl_index index, ecl_character value) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index] = value; + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index] = value; #endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index] = value; - default: + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index] = value; + default: FEwrong_type_nth_arg(@[si::char-set],1,object,@[string]); - } + } } #ifdef ECL_UNICODE static int compare_strings(cl_object string1, cl_index s1, cl_index e1, - cl_object string2, cl_index s2, cl_index e2, - int case_sensitive, cl_index *m) + cl_object string2, cl_index s2, cl_index e2, + int case_sensitive, cl_index *m) { - cl_index c1, c2; - for (; s1 < e1; s1++, s2++) { - if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = s1; - return +1; - } - c1 = ecl_char(string1, s1); - c2 = ecl_char(string2, s2); - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = s1; - return -1; - } else if (c1 > c2) { - *m = s1; - return +1; - } - } - *m = s1; - if (s2 >= e2) { - return 0; - } else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index c1, c2; + for (; s1 < e1; s1++, s2++) { + if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = s1; + return +1; + } + c1 = ecl_char(string1, s1); + c2 = ecl_char(string2, s2); + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = s1; + return -1; + } else if (c1 > c2) { + *m = s1; + return +1; + } + } + *m = s1; + if (s2 >= e2) { + return 0; + } else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } #endif static int compare_base(unsigned char *s1, cl_index l1, unsigned char *s2, cl_index l2, - int case_sensitive, cl_index *m) + int case_sensitive, cl_index *m) { - cl_index l, c1, c2; - for (l = 0; l < l1; l++, s1++, s2++) { - if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = l; - return +1; - } - c1 = *s1; - c2 = *s2; - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = l; - return -1; - } else if (c1 > c2) { - *m = l; - return +1; - } - } - *m = l; - if (l1 == l2) - return 0; - else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index l, c1, c2; + for (l = 0; l < l1; l++, s1++, s2++) { + if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = l; + return +1; + } + c1 = *s1; + c2 = *s2; + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = l; + return -1; + } else if (c1 > c2) { + *m = l; + return +1; + } + } + *m = l; + if (l1 == l2) + return 0; + else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } @(defun string= (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) + (start2 ecl_make_fixnum(0)) end2) cl_index_pair p; - cl_index s1, e1, s2, e2; + cl_index s1, e1, s2, e2; @ { - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); + p = ecl_vector_start_end(@[string=], string2, start2, end2); s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); + if (e1 - s1 != e2 - s2) + @(return ECL_NIL); #ifdef ECL_UNICODE - if (string1->string.t == t_string) { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } else { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } + if (string1->string.t == t_string) { + if (string2->string.t == t_string) { + while (s1 < e1) + if (string1->string.self[s1++] != string2->string.self[s2++]) + @(return ECL_NIL); + @(return ECL_T); + } else { + while (s1 < e1) + if (string1->string.self[s1++] != string2->base_string.self[s2++]) + @(return ECL_NIL); + @(return ECL_T); + } + } else { + if (string2->string.t == t_string) { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->string.self[s2++]) + @(return ECL_NIL); + @(return ECL_T); + } else { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) + @(return ECL_NIL); + @(return ECL_T); + } + } #else - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) + @(return ECL_NIL); #endif - @(return ECL_T); + @(return ECL_T); } @) /* - This correponds to string= (just the string equality). + This correponds to string= (just the string equality). */ bool ecl_string_eq(cl_object x, cl_object y) { - cl_index i, j; - i = x->base_string.fillp; - j = y->base_string.fillp; - if (i != j) return 0; + cl_index i, j; + i = x->base_string.fillp; + j = y->base_string.fillp; + if (i != j) return 0; #ifdef ECL_UNICODE - switch(ecl_t_of(x)) { - case t_string: - switch(ecl_t_of(y)) { - case t_string: - return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; - case t_base_string: { - cl_index index; - for(index=0; indexstring.self[index] != y->base_string.self[index]) - return 0; - return 1; - } - default: + switch(ecl_t_of(x)) { + case t_string: + switch(ecl_t_of(y)) { + case t_string: + return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; + case t_base_string: { + cl_index index; + for(index=0; indexstring.self[index] != y->base_string.self[index]) + return 0; + return 1; + } + default: FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - case t_base_string: - switch(ecl_t_of(y)) { - case t_string: - return ecl_string_eq(y, x); - case t_base_string: - return memcmp(x->base_string.self, y->base_string.self, i) == 0; - default: + } + break; + case t_base_string: + switch(ecl_t_of(y)) { + case t_string: + return ecl_string_eq(y, x); + case t_base_string: + return memcmp(x->base_string.self, y->base_string.self, i) == 0; + default: FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - default: + } + break; + default: FEwrong_type_nth_arg(@[string=],2,x,@[string]); - } + } #else - return memcmp(x->base_string.self, y->base_string.self, i) == 0; + return memcmp(x->base_string.self, y->base_string.self, i) == 0; #endif } @(defun string_equal (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) - cl_index s1, e1, s2, e2; + (start2 ecl_make_fixnum(0)) end2) + cl_index s1, e1, s2, e2; cl_index_pair p; - int output; + int output; @ - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); + p = ecl_vector_start_end(@[string=], string2, start2, end2); s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); + if (e1 - s1 != e2 - s2) + @(return ECL_NIL); #ifdef ECL_UNICODE if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); - } else + output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); + } else #endif - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - 0, &e1); - @(return ((output == 0)? ECL_T : ECL_NIL)) + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + 0, &e1); + @(return ((output == 0)? ECL_T : ECL_NIL)) @) static cl_object string_compare(cl_narg narg, int sign1, int sign2, int case_sensitive, ecl_va_list ARGS) { - cl_object string1 = ecl_va_arg(ARGS); - cl_object string2 = ecl_va_arg(ARGS); - cl_index s1, e1, s2, e2; + cl_object string1 = ecl_va_arg(ARGS); + cl_object string2 = ecl_va_arg(ARGS); + cl_index s1, e1, s2, e2; cl_index_pair p; - int output; - cl_object result; - cl_object KEYS[4]; + int output; + cl_object result; + cl_object KEYS[4]; #define start1 KEY_VARS[0] #define end1 KEY_VARS[1] #define start2 KEY_VARS[2] #define end2 KEY_VARS[3] #define start1p KEY_VARS[4] #define start2p KEY_VARS[6] - cl_object KEY_VARS[8]; + cl_object KEY_VARS[8]; - if (narg < 2) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start1'; - KEYS[1]=@':end1'; - KEYS[2]=@':start2'; - KEYS[3]=@':end2'; - cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 2) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start1'; + KEYS[1]=@':end1'; + KEYS[2]=@':start2'; + KEYS[3]=@':end2'; + cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); - string1 = cl_string(string1); - string2 = cl_string(string2); - if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); - if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); - p = ecl_vector_start_end(@[string=], string1, start1, end1); + string1 = cl_string(string1); + string2 = cl_string(string2); + if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); + if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); + p = ecl_vector_start_end(@[string=], string1, start1, end1); s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); + p = ecl_vector_start_end(@[string=], string2, start2, end2); s2 = p.start; e2 = p.end; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, - case_sensitive, &e1); - } else + if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { + output = compare_strings(string1, s1, e1, string2, s2, e2, + case_sensitive, &e1); + } else #endif - { - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - case_sensitive, &e1); - e1 += s1; - } - if (output == sign1 || output == sign2) { - result = ecl_make_fixnum(e1); - } else { - result = ECL_NIL; - } - @(return result) + { + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + case_sensitive, &e1); + e1 += s1; + } + if (output == sign1 || output == sign2) { + result = ecl_make_fixnum(e1); + } else { + result = ECL_NIL; + } + @(return result) #undef start1p #undef start2p #undef start1 @@ -600,171 +600,171 @@ string_compare(cl_narg narg, int sign1, int sign2, int case_sensitive, ecl_va_li @(defun string< (&rest args) @ - return string_compare(narg, -1, -1, 1, args); + return string_compare(narg, -1, -1, 1, args); @) @(defun string> (&rest args) @ - return string_compare(narg, +1, +1, 1, args); + return string_compare(narg, +1, +1, 1, args); @) @(defun string<= (&rest args) @ - return string_compare(narg, -1, 0, 1, args); + return string_compare(narg, -1, 0, 1, args); @) @(defun string>= (&rest args) @ - return string_compare(narg, 0, +1, 1, args); + return string_compare(narg, 0, +1, 1, args); @) @(defun string/= (&rest args) @ - return string_compare(narg, -1, +1, 1, args); + return string_compare(narg, -1, +1, 1, args); @) @(defun string-lessp (&rest args) @ - return string_compare(narg, -1, -1, 0, args); + return string_compare(narg, -1, -1, 0, args); @) @(defun string-greaterp (&rest args) @ - return string_compare(narg, +1, +1, 0, args); + return string_compare(narg, +1, +1, 0, args); @) @(defun string-not-greaterp (&rest args) @ - return string_compare(narg, -1, 0, 0, args); + return string_compare(narg, -1, 0, 0, args); @) @(defun string-not-lessp (&rest args) @ - return string_compare(narg, 0, +1, 0, args); + return string_compare(narg, 0, +1, 0, args); @) @(defun string-not-equal (&rest args) @ - return string_compare(narg, -1, +1, 0, args); + return string_compare(narg, -1, +1, 0, args); @) bool ecl_member_char(ecl_character c, cl_object char_bag) { - cl_index i, f; - switch (ecl_t_of(char_bag)) { - case t_list: - loop_for_in(char_bag) { - cl_object other = CAR(char_bag); - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } end_loop_for_in; - return(FALSE); - case t_vector: - for (i = 0, f = char_bag->vector.fillp; i < f; i++) { - cl_object other = char_bag->vector.self.t[i]; - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } - return(FALSE); + cl_index i, f; + switch (ecl_t_of(char_bag)) { + case t_list: + loop_for_in(char_bag) { + cl_object other = CAR(char_bag); + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } end_loop_for_in; + return(FALSE); + case t_vector: + for (i = 0, f = char_bag->vector.fillp; i < f; i++) { + cl_object other = char_bag->vector.self.t[i]; + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } + return(FALSE); #ifdef ECL_UNICODE - case t_string: - for (i = 0, f = char_bag->string.fillp; i < f; i++) { - if (c == char_bag->string.self[i]) - return(TRUE); - } - return(FALSE); + case t_string: + for (i = 0, f = char_bag->string.fillp; i < f; i++) { + if (c == char_bag->string.self[i]) + return(TRUE); + } + return(FALSE); #endif - case t_base_string: - for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { - if (c == char_bag->base_string.self[i]) - return(TRUE); - } - return(FALSE); - case t_bitvector: - return(FALSE); - default: - FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); - } + case t_base_string: + for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { + if (c == char_bag->base_string.self[i]) + return(TRUE); + } + return(FALSE); + case t_bitvector: + return(FALSE); + default: + FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); + } } static cl_object string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng) { - cl_index i, j; + cl_index i, j; - strng = cl_string(strng); - i = 0; - j = ecl_length(strng); - if (left_trim) { - for (; i < j; i++) { - cl_index c = ecl_char(strng, i); - if (!ecl_member_char(c, char_bag)) - break; - } - } - if (right_trim) { - for (; j > i; j--) { - cl_index c = ecl_char(strng, j-1); - if (!ecl_member_char(c, char_bag)) { - break; - } - } - } - return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); + strng = cl_string(strng); + i = 0; + j = ecl_length(strng); + if (left_trim) { + for (; i < j; i++) { + cl_index c = ecl_char(strng, i); + if (!ecl_member_char(c, char_bag)) + break; + } + } + if (right_trim) { + for (; j > i; j--) { + cl_index c = ecl_char(strng, j-1); + if (!ecl_member_char(c, char_bag)) { + break; + } + } + } + return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); } cl_object cl_string_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, TRUE, char_bag, strng); + return string_trim0(TRUE, TRUE, char_bag, strng); } cl_object cl_string_left_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, FALSE, char_bag, strng); + return string_trim0(TRUE, FALSE, char_bag, strng); } cl_object cl_string_right_trim(cl_object char_bag, cl_object strng) { - return string_trim0(FALSE, TRUE, char_bag, strng); + return string_trim0(FALSE, TRUE, char_bag, strng); } static cl_object string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); + cl_object strng = ecl_va_arg(ARGS); cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); strng = cl_string(strng); strng = cl_copy_seq(strng); - if (kstartp == ECL_NIL) + if (kstartp == ECL_NIL) kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); } else #endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng) #undef kstartp #undef kstart #undef kend @@ -773,81 +773,81 @@ string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) static ecl_character char_upcase(ecl_character c, bool *bp) { - return ecl_char_upcase(c); + return ecl_char_upcase(c); } @(defun string-upcase (&rest args) @ - return string_case(narg, @[string-upcase], char_upcase, args); + return string_case(narg, @[string-upcase], char_upcase, args); @) static ecl_character char_downcase(ecl_character c, bool *bp) { - return ecl_char_downcase(c); + return ecl_char_downcase(c); } @(defun string-downcase (&rest args) @ - return string_case(narg, @[string-downcase], char_downcase, args); + return string_case(narg, @[string-downcase], char_downcase, args); @) static ecl_character char_capitalize(ecl_character c, bool *bp) { - if (ecl_lower_case_p(c)) { - if (*bp) - c = ecl_char_upcase(c); - *bp = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!*bp) - c = ecl_char_downcase(c); - *bp = FALSE; - } else { - *bp = !ecl_alphanumericp(c); - } - return c; + if (ecl_lower_case_p(c)) { + if (*bp) + c = ecl_char_upcase(c); + *bp = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!*bp) + c = ecl_char_downcase(c); + *bp = FALSE; + } else { + *bp = !ecl_alphanumericp(c); + } + return c; } @(defun string-capitalize (&rest args) @ - return string_case(narg, @[string-capitalize], char_capitalize, args); + return string_case(narg, @[string-capitalize], char_capitalize, args); @) static cl_object nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); + cl_object strng = ecl_va_arg(ARGS); cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); if (ecl_unlikely(!ECL_STRINGP(strng))) FEwrong_type_nth_arg(fun, 1, strng, @[string]); - if (kstartp == ECL_NIL) + if (kstartp == ECL_NIL) kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - } else + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + } else #endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng) #undef kstartp #undef kstart #undef kend @@ -855,39 +855,39 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) @(defun nstring-upcase (&rest args) @ - return nstring_case(narg, @'nstring-upcase', char_upcase, args); + return nstring_case(narg, @'nstring-upcase', char_upcase, args); @) @(defun nstring-downcase (&rest args) @ - return nstring_case(narg, @'nstring-downcase', char_downcase, args); + return nstring_case(narg, @'nstring-downcase', char_downcase, args); @) @(defun nstring-capitalize (&rest args) @ - return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); + return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); @) @(defun si::base-string-concatenate (&rest args) - cl_index l; - int i; - cl_object output; + cl_index l; + int i; + cl_object output; @ - /* Compute final size and store NONEMPTY coerced strings. */ - for (i = 0, l = 0; i < narg; i++) { - cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); - if (s->base_string.fillp) { - ECL_STACK_PUSH(the_env, s); - l += s->base_string.fillp; - } - } - /* Do actual copying by recovering those strings */ - output = ecl_alloc_simple_base_string(l); - while (l) { - cl_object s = ECL_STACK_POP_UNSAFE(the_env); - size_t bytes = s->base_string.fillp; - l -= bytes; - memcpy(output->base_string.self + l, s->base_string.self, bytes); - } - @(return output); + /* Compute final size and store NONEMPTY coerced strings. */ + for (i = 0, l = 0; i < narg; i++) { + cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); + if (s->base_string.fillp) { + ECL_STACK_PUSH(the_env, s); + l += s->base_string.fillp; + } + } + /* Do actual copying by recovering those strings */ + output = ecl_alloc_simple_base_string(l); + while (l) { + cl_object s = ECL_STACK_POP_UNSAFE(the_env); + size_t bytes = s->base_string.fillp; + l -= bytes; + memcpy(output->base_string.self + l, s->base_string.self, bytes); + } + @(return output); @) diff --git a/src/c/structure.d b/src/c/structure.d index 66d59b825..2010bb5ee 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -29,57 +29,57 @@ static bool structure_subtypep(cl_object x, cl_object y) { - if (ECL_CLASS_NAME(x) == y) { - return TRUE; - } else { - cl_object superiors = ECL_CLASS_SUPERIORS(x); - loop_for_on_unsafe(superiors) { - if (structure_subtypep(ECL_CONS_CAR(superiors), y)) - return TRUE; - } end_loop_for_on_unsafe(superiors); - return FALSE; - } + if (ECL_CLASS_NAME(x) == y) { + return TRUE; + } else { + cl_object superiors = ECL_CLASS_SUPERIORS(x); + loop_for_on_unsafe(superiors) { + if (structure_subtypep(ECL_CONS_CAR(superiors), y)) + return TRUE; + } end_loop_for_on_unsafe(superiors); + return FALSE; + } } #else static bool structure_subtypep(cl_object x, cl_object y) { - do { - if (!ECL_SYMBOLP(x)) - return(FALSE); - if (x == y) - return(TRUE); - x = si_get_sysprop(x, @'si::structure-include'); - } while (x != ECL_NIL); - return(FALSE); + do { + if (!ECL_SYMBOLP(x)) + return(FALSE); + if (x == y) + return(TRUE); + x = si_get_sysprop(x, @'si::structure-include'); + } while (x != ECL_NIL); + return(FALSE); } #endif /* CLOS */ cl_object si_structure_subtype_p(cl_object x, cl_object y) { - @(return ((ecl_t_of(x) == T_STRUCTURE - && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)) + @(return ((ecl_t_of(x) == T_STRUCTURE + && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)) } @(defun si::make-structure (type &rest args) - cl_object x; - int i; + cl_object x; + int i; @ - x = ecl_alloc_object(T_STRUCTURE); - ECL_STRUCT_TYPE(x) = type; - ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ - ECL_STRUCT_LENGTH(x) = --narg; - ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); + x = ecl_alloc_object(T_STRUCTURE); + ECL_STRUCT_TYPE(x) = type; + ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ + ECL_STRUCT_LENGTH(x) = --narg; + ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); #ifdef CLOS x->instance.sig = ECL_UNBOUND; #endif - if (narg >= ECL_SLOTS_LIMIT) - FEerror("Limit on structure size exceeded: ~S slots requested.", - 1, ecl_make_fixnum(narg)); - for (i = 0; i < narg; i++) - ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); - @(return x) + if (narg >= ECL_SLOTS_LIMIT) + FEerror("Limit on structure size exceeded: ~S slots requested.", + 1, ecl_make_fixnum(narg)); + for (i = 0; i < narg; i++) + ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); + @(return x) @) #ifdef CLOS @@ -88,45 +88,45 @@ si_structure_subtype_p(cl_object x, cl_object y) cl_object ecl_copy_structure(cl_object x) { - cl_index j, size; - cl_object y; + cl_index j, size; + cl_object y; - if (ecl_unlikely(Null(si_structurep(x)))) - FEwrong_type_only_arg(@[copy-structure], x, @[structure]); - y = ecl_alloc_object(T_STRUCTURE); - ECL_STRUCT_TYPE(y) = ECL_STRUCT_TYPE(x); - ECL_STRUCT_LENGTH(y) = j = ECL_STRUCT_LENGTH(x); - size = sizeof(cl_object)*j; - ECL_STRUCT_SLOTS(y) = NULL; /* for GC sake */ - ECL_STRUCT_SLOTS(y) = (cl_object *)ecl_alloc_align(size, sizeof(cl_object)); - memcpy(ECL_STRUCT_SLOTS(y), ECL_STRUCT_SLOTS(x), size); + if (ecl_unlikely(Null(si_structurep(x)))) + FEwrong_type_only_arg(@[copy-structure], x, @[structure]); + y = ecl_alloc_object(T_STRUCTURE); + ECL_STRUCT_TYPE(y) = ECL_STRUCT_TYPE(x); + ECL_STRUCT_LENGTH(y) = j = ECL_STRUCT_LENGTH(x); + size = sizeof(cl_object)*j; + ECL_STRUCT_SLOTS(y) = NULL; /* for GC sake */ + ECL_STRUCT_SLOTS(y) = (cl_object *)ecl_alloc_align(size, sizeof(cl_object)); + memcpy(ECL_STRUCT_SLOTS(y), ECL_STRUCT_SLOTS(x), size); #ifdef CLOS y->instance.sig = x->instance.sig; #endif - @(return y) + @(return y) } #endif /* !CLOS */ cl_object cl_copy_structure(cl_object s) { - switch (ecl_t_of(s)) { - case t_instance: - s = ecl_copy_structure(s); - break; - case t_list: + switch (ecl_t_of(s)) { + case t_instance: + s = ecl_copy_structure(s); + break; + case t_list: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - case t_vector: - s = cl_copy_seq(s); - break; - default: + case t_base_string: + case t_bitvector: + case t_vector: + s = cl_copy_seq(s); + break; + default: FEwrong_type_only_arg(@[copy-structure], s, @[structure]); - } - @(return s) + } + @(return s) } @@ -134,61 +134,61 @@ cl_copy_structure(cl_object s) cl_object si_structure_name(cl_object s) { - if (ecl_unlikely(Null(si_structurep(s)))) + if (ecl_unlikely(Null(si_structurep(s)))) FEwrong_type_only_arg(@[si::structure-name], s, @[structure]); - @(return ECL_STRUCT_NAME(s)) + @(return ECL_STRUCT_NAME(s)) } cl_object si_structure_ref(cl_object x, cl_object type, cl_object index) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || !structure_subtypep(ECL_STRUCT_TYPE(x), type))) FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))) + @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))) } cl_object ecl_structure_ref(cl_object x, cl_object type, int n) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || !structure_subtypep(ECL_STRUCT_TYPE(x), type))) FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - return(ECL_STRUCT_SLOT(x, n)); + return(ECL_STRUCT_SLOT(x, n)); } cl_object si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || !structure_subtypep(ECL_STRUCT_TYPE(x), type))) FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; - @(return val) + ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; + @(return val) } cl_object ecl_structure_set(cl_object x, cl_object type, int n, cl_object v) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || !structure_subtypep(ECL_STRUCT_TYPE(x), type))) FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, n) = v; - return(v); + ECL_STRUCT_SLOT(x, n) = v; + return(v); } cl_object si_structurep(cl_object s) { #ifdef CLOS - if (ECL_INSTANCEP(s) && structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) - return ECL_T; + if (ECL_INSTANCEP(s) && structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) + return ECL_T; #else - if (ecl_t_of(s) == t_structure) - return ECL_T; + if (ecl_t_of(s) == t_structure) + return ECL_T; #endif - else - return ECL_NIL; + else + return ECL_NIL; } diff --git a/src/c/symbol.d b/src/c/symbol.d index 6228d17ee..d233d2617 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -87,394 +87,394 @@ static void FEtype_error_plist(cl_object x) /*__attribute__((noreturn))*/; cl_object cl_make_symbol(cl_object str) { - cl_object x; - /* INV: In several places it is assumed that we copy the string! */ - switch (ecl_t_of(str)) { + cl_object x; + /* INV: In several places it is assumed that we copy the string! */ + switch (ecl_t_of(str)) { #ifdef ECL_UNICODE - case t_string: - if (!ecl_fits_in_base_string(str)) { - str = cl_copy_seq(str); - } else { - str = si_copy_to_simple_base_string(str); - } - break; + case t_string: + if (!ecl_fits_in_base_string(str)) { + str = cl_copy_seq(str); + } else { + str = si_copy_to_simple_base_string(str); + } + break; #endif - case t_base_string: - str = si_copy_to_simple_base_string(str); - break; - default: - FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); - } - x = ecl_alloc_object(t_symbol); - x->symbol.name = str; - x->symbol.dynamic = 0; + case t_base_string: + str = si_copy_to_simple_base_string(str); + break; + default: + FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); + } + x = ecl_alloc_object(t_symbol); + x->symbol.name = str; + x->symbol.dynamic = 0; #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; -#endif /* */ - ECL_SET(x,OBJNULL); - ECL_SYM_FUN(x) = ECL_NIL; - x->symbol.plist = ECL_NIL; - x->symbol.hpack = ECL_NIL; - x->symbol.stype = ecl_stp_ordinary; - @(return x) + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; +#endif /* */ + ECL_SET(x,OBJNULL); + ECL_SYM_FUN(x) = ECL_NIL; + x->symbol.plist = ECL_NIL; + x->symbol.hpack = ECL_NIL; + x->symbol.stype = ecl_stp_ordinary; + @(return x) } /* - ecl_make_keyword(s) makes a keyword from C string s. + ecl_make_keyword(s) makes a keyword from C string s. */ cl_object ecl_make_keyword(const char *s) { - cl_object x = _ecl_intern(s, cl_core.keyword_package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object x = _ecl_intern(s, cl_core.keyword_package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_make_symbol(const char *s, const char *p) { - cl_object package = ecl_find_package(p); - cl_object x = _ecl_intern(s, package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object package = ecl_find_package(p); + cl_object x = _ecl_intern(s, package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_symbol_value(cl_object s) { - if (Null(s)) { - return s; - } else { - /* FIXME: Should we check symbol type? */ - const cl_env_ptr the_env = ecl_process_env(); - cl_object value = ECL_SYM_VAL(the_env, s); - unlikely_if (value == OBJNULL) - FEunbound_variable(s); - return value; - } + if (Null(s)) { + return s; + } else { + /* FIXME: Should we check symbol type? */ + const cl_env_ptr the_env = ecl_process_env(); + cl_object value = ECL_SYM_VAL(the_env, s); + unlikely_if (value == OBJNULL) + FEunbound_variable(s); + return value; + } } static void FEtype_error_plist(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid property list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'si::property-list', - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid property list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'si::property-list', + @':datum', x); } cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) - return ECL_CONS_CAR(cdr_l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - return(deflt); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) + return ECL_CONS_CAR(cdr_l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + return(deflt); } cl_object ecl_get(cl_object s, cl_object p, cl_object d) { - return ecl_getf(*ecl_symbol_plist(s), p, d); + return ecl_getf(*ecl_symbol_plist(s), p, d); } /* - (SI:PUT-F plist value indicator) - returns the new property list with value for property indicator. - It will be used in SETF for GETF. + (SI:PUT-F plist value indicator) + returns the new property list with value for property indicator. + It will be used in SETF for GETF. */ cl_object si_put_f(cl_object place, cl_object value, cl_object indicator) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - /* This loop guarantees finishing for circular lists */ - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) { - ECL_RPLACA(cdr_l, value); - @(return place); - } - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - place = CONS(value, place); - @(return CONS(indicator, place)); + /* This loop guarantees finishing for circular lists */ + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) { + ECL_RPLACA(cdr_l, value); + @(return place); + } + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + place = CONS(value, place); + @(return CONS(indicator, place)); } /* - Remf(p, i) removes property i - from the property list pointed by p, - which is a pointer to an cl_object. - The returned value of remf(p, i) is: + Remf(p, i) removes property i + from the property list pointed by p, + which is a pointer to an cl_object. + The returned value of remf(p, i) is: - TRUE if the property existed - FALSE otherwise. + TRUE if the property existed + FALSE otherwise. */ static bool remf(cl_object *place, cl_object indicator) { - cl_object l = *place, tail = ECL_NIL; - while (!Null(l)) { - cl_object ind; - if (!LISTP(l)) - FEtype_error_plist(*place); - ind = ECL_CONS_CAR(l); - l = ECL_CONS_CDR(l); - if (!CONSP(l)) - FEtype_error_plist(*place); - if (ind == indicator) { - l = ECL_CONS_CDR(l); - if (Null(tail)) - *place = l; - else - ECL_RPLACD(tail, l); - return TRUE; - } - tail = l; - l = ECL_CONS_CDR(l); - } - return FALSE; + cl_object l = *place, tail = ECL_NIL; + while (!Null(l)) { + cl_object ind; + if (!LISTP(l)) + FEtype_error_plist(*place); + ind = ECL_CONS_CAR(l); + l = ECL_CONS_CDR(l); + if (!CONSP(l)) + FEtype_error_plist(*place); + if (ind == indicator) { + l = ECL_CONS_CDR(l); + if (Null(tail)) + *place = l; + else + ECL_RPLACD(tail, l); + return TRUE; + } + tail = l; + l = ECL_CONS_CDR(l); + } + return FALSE; } bool ecl_keywordp(cl_object s) { - return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); + return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); } @(defun get (sym indicator &optional deflt) - cl_object *plist; + cl_object *plist; @ - plist = ecl_symbol_plist(sym); - @(return ecl_getf(*plist, indicator, deflt)) + plist = ecl_symbol_plist(sym); + @(return ecl_getf(*plist, indicator, deflt)) @) cl_object cl_remprop(cl_object sym, cl_object prop) { - cl_object *plist = ecl_symbol_plist(sym); - @(return (remf(plist, prop)? ECL_T: ECL_NIL)) + cl_object *plist = ecl_symbol_plist(sym); + @(return (remf(plist, prop)? ECL_T: ECL_NIL)) } cl_object cl_symbol_plist(cl_object sym) { - @(return *ecl_symbol_plist(sym)) + @(return *ecl_symbol_plist(sym)) } @(defun getf (place indicator &optional deflt) @ - @(return ecl_getf(place, indicator, deflt)) + @(return ecl_getf(place, indicator, deflt)) @) cl_object cl_get_properties(cl_object place, cl_object indicator_list) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object l; + const cl_env_ptr the_env = ecl_process_env(); + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) - ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) + ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); } cl_object cl_symbol_name(cl_object x) { - ecl_return1(ecl_process_env(), ecl_symbol_name(x)); + ecl_return1(ecl_process_env(), ecl_symbol_name(x)); } @(defun copy_symbol (sym &optional cp &aux x) @ - if (Null(sym)) - sym = ECL_NIL_SYMBOL; - x = cl_make_symbol(ecl_symbol_name(sym)); - if (!Null(cp)) { - x->symbol.dynamic = 0; - x->symbol.stype = sym->symbol.stype; - x->symbol.value = sym->symbol.value; - x->symbol.gfdef = sym->symbol.gfdef; - x->symbol.plist = cl_copy_list(sym->symbol.plist); + if (Null(sym)) + sym = ECL_NIL_SYMBOL; + x = cl_make_symbol(ecl_symbol_name(sym)); + if (!Null(cp)) { + x->symbol.dynamic = 0; + x->symbol.stype = sym->symbol.stype; + x->symbol.value = sym->symbol.value; + x->symbol.gfdef = sym->symbol.gfdef; + x->symbol.plist = cl_copy_list(sym->symbol.plist); #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - /* FIXME!!! We should also copy the system property list */ - } - @(return x) + /* FIXME!!! We should also copy the system property list */ + } + @(return x) @) @(defun gensym (&optional (prefix cl_core.gensym_prefix)) - cl_type t; - cl_object counter, output; - bool increment; + cl_type t; + cl_object counter, output; + bool increment; @ { - if (ecl_stringp(prefix)) { - counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); - increment = 1; - } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { - counter = prefix; - prefix = cl_core.gensym_prefix; - increment = 0; - } else { + if (ecl_stringp(prefix)) { + counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); + increment = 1; + } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { + counter = prefix; + prefix = cl_core.gensym_prefix; + increment = 0; + } else { FEwrong_type_nth_arg(@[gensym],2,prefix, cl_list(3, @'or', @'string', @'integer')); - } - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(counter, output); - ecl_bds_unwind_n(the_env, 4); - output = cl_make_symbol(cl_get_output_stream_string(output)); - if (increment) - ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); - @(return output); + } + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(counter, output); + ecl_bds_unwind_n(the_env, 4); + output = cl_make_symbol(cl_get_output_stream_string(output)); + if (increment) + ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); + @(return output); } @) @(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack ecl_current_package())) - cl_object output, s; - int intern_flag; + cl_object output, s; + int intern_flag; @ unlikely_if (!ECL_STRINGP(prefix)) FEwrong_type_nth_arg(@[gentemp], 1, prefix, @[string]); - pack = si_coerce_to_package(pack); + pack = si_coerce_to_package(pack); ONCE_MORE: - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(cl_core.gentemp_counter, output); - ecl_bds_unwind_n(the_env, 4); - cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); - s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); - if (intern_flag != 0) - goto ONCE_MORE; - @(return s) + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(cl_core.gentemp_counter, output); + ecl_bds_unwind_n(the_env, 4); + cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); + s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); + if (intern_flag != 0) + goto ONCE_MORE; + @(return s) @) cl_object cl_symbol_package(cl_object sym) { - @(return ecl_symbol_package(sym)) + @(return ecl_symbol_package(sym)) } cl_object cl_keywordp(cl_object sym) { - @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)) + @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)) } /* - (SI:REM-F plist indicator) returns two values: + (SI:REM-F plist indicator) returns two values: - * the new property list - in which property indcator is removed + * the new property list + in which property indcator is removed - * T if really removed - NIL otherwise. + * T if really removed + NIL otherwise. - It will be used for macro REMF. + It will be used for macro REMF. */ cl_object si_rem_f(cl_object plist, cl_object indicator) { - cl_env_ptr the_env = ecl_process_env(); - bool found = remf(&plist, indicator); - ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); + cl_env_ptr the_env = ecl_process_env(); + bool found = remf(&plist, indicator); + ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); } cl_object si_set_symbol_plist(cl_object sym, cl_object plist) { - *ecl_symbol_plist(sym) = plist; - @(return plist) + *ecl_symbol_plist(sym) = plist; + @(return plist) } cl_object si_putprop(cl_object sym, cl_object value, cl_object indicator) { - cl_object *plist = ecl_symbol_plist(sym); - *plist = si_put_f(*plist, value, indicator); - @(return value) + cl_object *plist = ecl_symbol_plist(sym); + *plist = si_put_f(*plist, value, indicator); + @(return value) } /* Added for defstruct. Beppe */ @(defun si::put-properties (sym &rest ind_values) @ - while (--narg >= 2) { - cl_object prop = ecl_va_arg(ind_values); - si_putprop(sym, ecl_va_arg(ind_values), prop); - narg--; - } - @(return sym) + while (--narg >= 2) { + cl_object prop = ecl_va_arg(ind_values); + si_putprop(sym, ecl_va_arg(ind_values), prop); + narg--; + } + @(return sym) @) cl_object @si::*make-special(cl_object sym) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_constant) - FEerror("~S is a constant.", 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_special); - cl_remprop(sym, @'si::symbol-macro'); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_constant) + FEerror("~S is a constant.", 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_special); + cl_remprop(sym, @'si::symbol-macro'); + @(return sym) } cl_object @si::*make-constant(cl_object sym, cl_object val) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special) - FEerror("The argument ~S to DEFCONSTANT is a special variable.", - 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_constant); - ECL_SET(sym, val); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special) + FEerror("The argument ~S to DEFCONSTANT is a special variable.", + 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_constant); + ECL_SET(sym, val); + @(return sym) } void ecl_defvar(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } void ecl_defparameter(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 5a5f64cd4..b35674bdf 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -23,7 +23,7 @@ #define GRAY_ "GRAY::" #define FFI_ "FFI::" typedef struct { - const char *name, *translation; + const char *name, *translation; } cl_symbol_initializer; #else #include "ecl_constants.h" diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 70fdd1ae6..5c6786c31 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -23,7 +23,7 @@ #define GRAY_ "GRAY::" #define FFI_ "FFI::" typedef struct { - const char *name, *translation; + const char *name, *translation; } cl_symbol_initializer; #else #include "ecl_constants.h" diff --git a/src/c/tcp.d b/src/c/tcp.d index 4e88c82c3..1418d5b08 100644 --- a/src/c/tcp.d +++ b/src/c/tcp.d @@ -1,5 +1,5 @@ /* -*- mode: c; c-basic-offset: 8 -*- */ -/* tcp.c -- stream interface to TCP */ +/* tcp.c -- stream interface to TCP */ /* Copyright (c) 1990, Giuseppe Attardi. @@ -39,19 +39,19 @@ extern int errno; #endif /* Maximum length for a unix socket pathname */ -#define UNIX_MAX_PATH 107 +#define UNIX_MAX_PATH 107 #if defined(ECL_MS_WINDOWS_HOST) WSADATA wsadata; int wsock_initialized = 0; -#define INIT_TCP \ - if ( !wsock_initialized ) \ - { \ - if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ - FEerror( "Unable to initialize Windows socket library.", 0 ); \ - else \ - wsock_initialized = 1; \ - } +#define INIT_TCP \ + if ( !wsock_initialized ) \ + { \ + if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ + FEerror( "Unable to initialize Windows socket library.", 0 ); \ + else \ + wsock_initialized = 1; \ + } #else #define INIT_TCP #endif @@ -60,11 +60,11 @@ void ecl_tcp_close_all(void) { #if defined(ECL_MS_WINDOWS_HOST) - if ( wsock_initialized ) - { - WSACleanup(); - wsock_initialized = 0; - } + if ( wsock_initialized ) + { + WSACleanup(); + wsock_initialized = 0; + } #endif } @@ -79,15 +79,15 @@ ecl_tcp_close_all(void) static int connect_to_server(char *host, int port) { - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ + struct sockaddr_in inaddr; /* INET socket address. */ + struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; - int addrlen; /* length of address */ + int addrlen; /* length of address */ #if !defined(ECL_MS_WINDOWS_HOST) extern char *getenv(); extern struct hostent *gethostbyname(); #endif - int fd; /* Network socket */ + int fd; /* Network socket */ INIT_TCP @@ -111,7 +111,7 @@ int connect_to_server(char *host, int port) /* Set up the socket data. */ inaddr.sin_family = host_ptr->h_addrtype; memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); + sizeof(inaddr.sin_addr)); } else inaddr.sin_family = AF_INET; @@ -124,7 +124,7 @@ int connect_to_server(char *host, int port) * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) - return(0); /* errno set by system call. */ + return(0); /* errno set by system call. */ ecl_disable_interrupts(); #ifdef TCP_NODELAY @@ -163,10 +163,10 @@ int connect_to_server(char *host, int port) int create_server_port(int port) { - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ - int addrlen; /* length of address */ - int request, conn; /* Network socket */ + struct sockaddr_in inaddr; /* INET socket address. */ + struct sockaddr *addr; /* address to connect to */ + int addrlen; /* length of address */ + int request, conn; /* Network socket */ INIT_TCP @@ -174,20 +174,20 @@ create_server_port(int port) * Open the network connection. */ if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { - return(0); /* errno set by system call. */ + return(0); /* errno set by system call. */ } #ifdef SO_REUSEADDR /* Necesary to restart the server without a reboot */ #if defined(ECL_MS_WINDOWS_HOST) { - char one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); + char one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); } #else { - int one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); + int one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); } #endif #endif /* SO_REUSEADDR */ @@ -226,13 +226,13 @@ create_server_port(int port) * on reading returns streams */ { - FILE *fp; /* need to use FILE *'s rather than fd... *sigh* */ + FILE *fp; /* need to use FILE *'s rather than fd... *sigh* */ if ((fp = fdopen(request, "r")) == (FILE *)0) printf("fdopen didn't work on accept fd!\n"); fflush(stdout); fcntl(request, F_SETFL, O_NONBLOCK); clearerr(fp); - loop: errno = 0; + loop: errno = 0; if ((conn = accept(request, (struct sockaddr *)NULL, (int *)NULL)) < 0) if (errno) { lwpblockon(active, fp, PD_INPUT); @@ -247,7 +247,7 @@ create_server_port(int port) #else if ((conn = accept(request, (struct sockaddr *)NULL, NULL)) < 0) FElibc_error("Accepting requests", 0); -#endif /* THREADS */ +#endif /* THREADS */ return(conn); } @@ -267,7 +267,7 @@ create_server_port(int port) cl_object si_open_client_stream(cl_object host, cl_object port) { - int fd, p; /* file descriptor */ + int fd, p; /* file descriptor */ cl_object stream; /* Ensure "host" is a string that we can pass to a C function */ @@ -303,7 +303,7 @@ si_open_client_stream(cl_object host, cl_object port) cl_object si_open_server_stream(cl_object port) { - int fd; /* file descriptor */ + int fd; /* file descriptor */ cl_index p; if (ecl_unlikely(!ECL_FIXNUMP(port) || @@ -321,92 +321,92 @@ si_open_server_stream(cl_object port) } /************************************************************ - * Unix sockets * + * Unix sockets * ************************************************************/ cl_object si_open_unix_socket_stream(cl_object path) { #if defined(ECL_MS_WINDOWS_HOST) - FEerror("UNIX socket not supported under Win32 platform", 0); + FEerror("UNIX socket not supported under Win32 platform", 0); #else - int fd; /* file descriptor */ - struct sockaddr_un addr; + int fd; /* file descriptor */ + struct sockaddr_un addr; - if (ecl_unlikely(ecl_t_of(path) != t_base_string)) + if (ecl_unlikely(ecl_t_of(path) != t_base_string)) FEwrong_type_nth_arg(@[si::open-unix-socket-stream], 1, path, @[string]); - if (path->base_string.fillp > UNIX_MAX_PATH-1) - FEerror("~S is a too long file name.", 1, path); + if (path->base_string.fillp > UNIX_MAX_PATH-1) + FEerror("~S is a too long file name.", 1, path); - fd = socket(PF_UNIX, SOCK_STREAM, 0); - if (fd < 0) { - FElibc_error("Unable to create unix socket", 0); - @(return ECL_NIL) - } + fd = socket(PF_UNIX, SOCK_STREAM, 0); + if (fd < 0) { + FElibc_error("Unable to create unix socket", 0); + @(return ECL_NIL) + } - memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); - addr.sun_path[path->base_string.fillp] = 0; - addr.sun_family = AF_UNIX; + memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); + addr.sun_path[path->base_string.fillp] = 0; + addr.sun_family = AF_UNIX; - if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { - close(fd); - FElibc_error("Unable to connect to unix socket ~A", 1, path); - @(return ECL_NIL) - } + if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { + close(fd); + FElibc_error("Unable to connect to unix socket ~A", 1, path); + @(return ECL_NIL) + } - @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)) + @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)) #endif } /************************************************************ - * Hostname resolution * + * Hostname resolution * ************************************************************/ cl_object si_lookup_host_entry(cl_object host_or_address) { - struct hostent *he; - unsigned long l; - char address[4]; - cl_object name, aliases, addresses; - int i; + struct hostent *he; + unsigned long l; + char address[4]; + cl_object name, aliases, addresses; + int i; - INIT_TCP + INIT_TCP - switch (ecl_t_of(host_or_address)) { + switch (ecl_t_of(host_or_address)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - host_or_address = si_copy_to_simple_base_string(host_or_address); - he = gethostbyname((char*)host_or_address->base_string.self); - break; - case t_fixnum: - l = ecl_fixnum(host_or_address); - goto addr; - case t_bignum: - l = _ecl_big_to_ulong(host_or_address); - addr: address[0] = l & 0xFF; - address[1] = (l >> 8) & 0xFF; - address[2] = (l >> 16) & 0xFF; - address[3] = (l >> 24) & 0xFF; - he = gethostbyaddr(&address, 4, AF_INET); - break; - default: - FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", - 1, host_or_address); - } - if (he == NULL) - @(return ECL_NIL ECL_NIL ECL_NIL) - name = make_base_string_copy(he->h_name); - aliases = ECL_NIL; - for (i = 0; he->h_aliases[i] != 0; i++) - aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); - addresses = ECL_NIL; - for (i = 0; he->h_addr_list[i]; i++) { - unsigned long *s = (unsigned long*)(he->h_addr_list[i]); - l = *s; - addresses = CONS(ecl_make_integer(l), addresses); - } - @(return name aliases addresses) + case t_base_string: + host_or_address = si_copy_to_simple_base_string(host_or_address); + he = gethostbyname((char*)host_or_address->base_string.self); + break; + case t_fixnum: + l = ecl_fixnum(host_or_address); + goto addr; + case t_bignum: + l = _ecl_big_to_ulong(host_or_address); + addr: address[0] = l & 0xFF; + address[1] = (l >> 8) & 0xFF; + address[2] = (l >> 16) & 0xFF; + address[3] = (l >> 24) & 0xFF; + he = gethostbyaddr(&address, 4, AF_INET); + break; + default: + FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", + 1, host_or_address); + } + if (he == NULL) + @(return ECL_NIL ECL_NIL ECL_NIL) + name = make_base_string_copy(he->h_name); + aliases = ECL_NIL; + for (i = 0; he->h_aliases[i] != 0; i++) + aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); + addresses = ECL_NIL; + for (i = 0; he->h_addr_list[i]; i++) { + unsigned long *s = (unsigned long*)(he->h_addr_list[i]); + l = *s; + addresses = CONS(ecl_make_integer(l), addresses); + } + @(return name aliases addresses) } diff --git a/src/c/threads/atomic.d b/src/c/threads/atomic.d index 8ee41f796..b2b0370bb 100755 --- a/src/c/threads/atomic.d +++ b/src/c/threads/atomic.d @@ -24,11 +24,11 @@ cl_object ecl_atomic_get(cl_object *slot) { - cl_object old; - do { - old = (cl_object)AO_load((AO_t*)slot); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); - return old; + cl_object old; + do { + old = (cl_object)AO_load((AO_t*)slot); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); + return old; } void @@ -47,7 +47,7 @@ ecl_atomic_pop(cl_object *slot) cl_object cons, rest; do { cons = (cl_object)AO_load((AO_t*)slot); - rest = CDR(cons); + rest = CDR(cons); } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cons, (AO_t)rest)); return cons; } @@ -55,13 +55,13 @@ ecl_atomic_pop(cl_object *slot) cl_index ecl_atomic_index_incf(cl_index *slot) { - AO_t old; - AO_t next; - do { - old = AO_load((AO_t*)slot); - next = old+1; - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); - return (cl_index)next; + AO_t old; + AO_t next; + do { + old = AO_load((AO_t*)slot); + next = old+1; + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); + return (cl_index)next; } #endif /* ECL_THREADS */ diff --git a/src/c/threads/barrier.d b/src/c/threads/barrier.d index 94fb8a5ca..d030b0e8e 100755 --- a/src/c/threads/barrier.d +++ b/src/c/threads/barrier.d @@ -27,143 +27,143 @@ FEerror_not_a_barrier(cl_object barrier) cl_object ecl_make_barrier(cl_object name, cl_index count) { - cl_object output = ecl_alloc_object(t_barrier); - output->barrier.name = name; - output->barrier.arrivers_count = count; - output->barrier.count = count; - output->barrier.queue_list = ECL_NIL; - output->barrier.queue_spinlock = ECL_NIL; + cl_object output = ecl_alloc_object(t_barrier); + output->barrier.name = name; + output->barrier.arrivers_count = count; + output->barrier.count = count; + output->barrier.queue_list = ECL_NIL; + output->barrier.queue_spinlock = ECL_NIL; return output; } @(defun mp::make-barrier (count &key name) @ - if (count == ECL_T) - count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - @(return ecl_make_barrier(name, fixnnint(count))) + if (count == ECL_T) + count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + @(return ecl_make_barrier(name, fixnnint(count))) @) cl_object mp_barrier_name(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } ecl_return1(env, barrier->barrier.name); } cl_object mp_barrier_count(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); } cl_object mp_barrier_arrivers_count(cl_object barrier) { - cl_fixnum arrivers, count; - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - arrivers = barrier->barrier.arrivers_count; - count = barrier->barrier.count; - if (arrivers < 0) - arrivers = 0; /* Disabled barrier */ - else - arrivers = count - arrivers; - ecl_return1(env, ecl_make_fixnum(arrivers)); + cl_fixnum arrivers, count; + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + arrivers = barrier->barrier.arrivers_count; + count = barrier->barrier.count; + if (arrivers < 0) + arrivers = 0; /* Disabled barrier */ + else + arrivers = count - arrivers; + ecl_return1(env, ecl_make_fixnum(arrivers)); } @(defun mp::barrier-unblock (barrier &key reset_count disable kill_waiting) - int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; - int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; + int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; + int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; @ - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - if (!Null(reset_count)) - barrier->barrier.count = fixnnint(reset_count); - if (!Null(disable)) - barrier->barrier.arrivers_count = -1; - else - barrier->barrier.arrivers_count = barrier->barrier.count; - ecl_wakeup_waiters(the_env, barrier, - Null(kill_waiting)? ping_flags : kill_flags); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + if (!Null(reset_count)) + barrier->barrier.count = fixnnint(reset_count); + if (!Null(disable)) + barrier->barrier.arrivers_count = -1; + else + barrier->barrier.arrivers_count = barrier->barrier.count; + ecl_wakeup_waiters(the_env, barrier, + Null(kill_waiting)? ping_flags : kill_flags); @(return) @) static cl_object barrier_wait_condition(cl_env_ptr env, cl_object barrier) { - /* We were signaled */ - if (env->own_process->process.woken_up != ECL_NIL) - return ECL_T; - /* Disabled barrier */ - else if (barrier->barrier.arrivers_count < 0) - return ECL_T; - else - return ECL_NIL; + /* We were signaled */ + if (env->own_process->process.woken_up != ECL_NIL) + return ECL_T; + /* Disabled barrier */ + else if (barrier->barrier.arrivers_count < 0) + return ECL_T; + else + return ECL_NIL; } static cl_fixnum decrement_counter(cl_fixnum *counter) { - /* The logic is as follows: - * - If the counter is negative, we abort. This is a way of - * disabling the counter. - * - Otherwise, we decrease the counter only if it is positive - * - If the counter is currently zero, then we block. This - * situation implies that some other thread is unblocking. - */ - cl_fixnum c; - do { - c = *counter; - if (c < 0) { - return c; - } else if (c > 0) { - if (AO_compare_and_swap_full((AO_t*)counter, - (AO_t)c, (AO_t)(c-1))) - return c; - } - } while (1); + /* The logic is as follows: + * - If the counter is negative, we abort. This is a way of + * disabling the counter. + * - Otherwise, we decrease the counter only if it is positive + * - If the counter is currently zero, then we block. This + * situation implies that some other thread is unblocking. + */ + cl_fixnum c; + do { + c = *counter; + if (c < 0) { + return c; + } else if (c > 0) { + if (AO_compare_and_swap_full((AO_t*)counter, + (AO_t)c, (AO_t)(c-1))) + return c; + } + } while (1); } @(defun mp::barrier-wait (barrier &key) - cl_object output; - cl_fixnum counter; + cl_object output; + cl_fixnum counter; @ { - cl_object own_process = the_env->own_process; + cl_object own_process = the_env->own_process; - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_disable_interrupts_env(the_env); - counter = decrement_counter(&barrier->barrier.arrivers_count); - if (counter == 0) { - print_lock("barrier %p saturated", barrier, barrier); - /* There are (count-1) threads in the queue and we - * are the last one. We thus unblock all threads and - * proceed. */ - mp_barrier_unblock(1, barrier); - ecl_enable_interrupts_env(the_env); - output = @':unblocked'; - } else if (counter > 0) { - print_lock("barrier %p waiting", barrier, barrier); - ecl_enable_interrupts_env(the_env); - ecl_wait_on(the_env, barrier_wait_condition, barrier); - output = ECL_T; - } else { - print_lock("barrier %p pass-through", barrier, barrier); - /* Barrier disabled */ - output = ECL_NIL; - } - @(return output) + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_disable_interrupts_env(the_env); + counter = decrement_counter(&barrier->barrier.arrivers_count); + if (counter == 0) { + print_lock("barrier %p saturated", barrier, barrier); + /* There are (count-1) threads in the queue and we + * are the last one. We thus unblock all threads and + * proceed. */ + mp_barrier_unblock(1, barrier); + ecl_enable_interrupts_env(the_env); + output = @':unblocked'; + } else if (counter > 0) { + print_lock("barrier %p waiting", barrier, barrier); + ecl_enable_interrupts_env(the_env); + ecl_wait_on(the_env, barrier_wait_condition, barrier); + output = ECL_T; + } else { + print_lock("barrier %p pass-through", barrier, barrier); + /* Barrier disabled */ + output = ECL_NIL; + } + @(return output) } @) diff --git a/src/c/threads/condition_variable.d b/src/c/threads/condition_variable.d index 9670c5b38..3b9a075c5 100644 --- a/src/c/threads/condition_variable.d +++ b/src/c/threads/condition_variable.d @@ -23,46 +23,46 @@ cl_object mp_make_condition_variable(void) { - cl_object output = ecl_alloc_object(t_condition_variable); - output->condition_variable.queue_list = ECL_NIL; - output->condition_variable.queue_spinlock = ECL_NIL; - output->condition_variable.lock = ECL_NIL; - @(return output) + cl_object output = ecl_alloc_object(t_condition_variable); + output->condition_variable.queue_list = ECL_NIL; + output->condition_variable.queue_spinlock = ECL_NIL; + output->condition_variable.lock = ECL_NIL; + @(return output) } static cl_object condition_variable_wait(cl_env_ptr env, cl_object cv) { - cl_object lock = cv->condition_variable.lock; - cl_object own_process = env->own_process; - /* We have entered the queue and still own the mutex? */ - print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); - if (lock->lock.owner == own_process) { - mp_giveup_lock(lock); - } - /* We always return when we have been explicitly awaken */ - return own_process->process.woken_up; + cl_object lock = cv->condition_variable.lock; + cl_object own_process = env->own_process; + /* We have entered the queue and still own the mutex? */ + print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); + if (lock->lock.owner == own_process) { + mp_giveup_lock(lock); + } + /* We always return when we have been explicitly awaken */ + return own_process->process.woken_up; } cl_object mp_condition_variable_wait(cl_object cv, cl_object lock) { cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(cv) != t_condition_variable) { + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(cv) != t_condition_variable) { FEwrong_type_nth_arg(@[mp::condition-variable-wait], 1, cv, @[mp::condition-variable]); - } - unlikely_if (ecl_t_of(lock) != t_lock) { + } + unlikely_if (ecl_t_of(lock) != t_lock) { FEwrong_type_nth_arg(@[mp::condition-variable-wait], 2, lock, @[mp::lock]); - } + } unlikely_if (cv->condition_variable.lock != ECL_NIL && - cv->condition_variable.lock != lock) - { + cv->condition_variable.lock != lock) + { FEerror("Attempt to associate lock ~A~%with condition variable ~A," - "~%which is already associated to lock ~A", 2, lock, - cv, cv->condition_variable.lock); + "~%which is already associated to lock ~A", 2, lock, + cv, cv->condition_variable.lock); } unlikely_if (lock->lock.owner != own_process) { FEerror("Attempt to wait on a condition variable using lock~%~S" @@ -72,33 +72,33 @@ mp_condition_variable_wait(cl_object cv, cl_object lock) FEerror("mp:condition-variable-wait can not be used with recursive" " locks:~%~S", 1, lock); } - print_lock("waiting cv %p", cv, cv); - cv->condition_variable.lock = lock; - ecl_wait_on(env, condition_variable_wait, cv); - mp_get_lock_wait(lock); - @(return ECL_T) + print_lock("waiting cv %p", cv, cv); + cv->condition_variable.lock = lock; + ecl_wait_on(env, condition_variable_wait, cv); + mp_get_lock_wait(lock); + @(return ECL_T) } cl_object mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) { - FEerror("Timed condition variables are not supported.", 0); + FEerror("Timed condition variables are not supported.", 0); } cl_object mp_condition_variable_signal(cl_object cv) { - print_lock("signal cv %p", cv, cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("signal cv %p", cv, cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); + @(return ECL_T) } cl_object mp_condition_variable_broadcast(cl_object cv) { - print_lock("broadcast cv %p", cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("broadcast cv %p", cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); + @(return ECL_T) } diff --git a/src/c/threads/mailbox.d b/src/c/threads/mailbox.d index ae0a66d32..fdda559df 100755 --- a/src/c/threads/mailbox.d +++ b/src/c/threads/mailbox.d @@ -27,100 +27,100 @@ FEerror_not_a_mailbox(cl_object mailbox) cl_object ecl_make_mailbox(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_mailbox); - cl_fixnum mask; - for (mask = 1; mask < count; mask <<= 1) {} - if (mask == 1) - mask = 63; - count = mask; - mask = count - 1; - output->mailbox.name = name; - output->mailbox.data = si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(count), /* size */ - ECL_NIL, /* adjustable */ - ECL_NIL, /* fill pointer */ - ECL_NIL, /* displaced to */ - ECL_NIL); /* displacement */ - output->mailbox.reader_semaphore = - ecl_make_semaphore(name, 0); - output->mailbox.writer_semaphore = - ecl_make_semaphore(name, count); - output->mailbox.read_pointer = 0; - output->mailbox.write_pointer = 0; - output->mailbox.mask = mask; + cl_object output = ecl_alloc_object(t_mailbox); + cl_fixnum mask; + for (mask = 1; mask < count; mask <<= 1) {} + if (mask == 1) + mask = 63; + count = mask; + mask = count - 1; + output->mailbox.name = name; + output->mailbox.data = si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(count), /* size */ + ECL_NIL, /* adjustable */ + ECL_NIL, /* fill pointer */ + ECL_NIL, /* displaced to */ + ECL_NIL); /* displacement */ + output->mailbox.reader_semaphore = + ecl_make_semaphore(name, 0); + output->mailbox.writer_semaphore = + ecl_make_semaphore(name, count); + output->mailbox.read_pointer = 0; + output->mailbox.write_pointer = 0; + output->mailbox.mask = mask; return output; } @(defun mp::make-mailbox (&key name (count ecl_make_fixnum(128))) @ { - @(return ecl_make_mailbox(name, fixnnint(count))) + @(return ecl_make_mailbox(name, fixnnint(count))) } @) cl_object mp_mailbox_name(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } ecl_return1(env, mailbox->mailbox.name); } cl_object mp_mailbox_count(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); } cl_object mp_mailbox_empty_p(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); } cl_object mp_mailbox_read(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - cl_object output; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & - mailbox->mailbox.mask; - output = mailbox->mailbox.data->vector.self.t[ndx]; - } - mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + cl_object output; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & + mailbox->mailbox.mask; + output = mailbox->mailbox.data->vector.self.t[ndx]; + } + mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); + ecl_return1(env, output); } cl_object mp_mailbox_send(cl_object mailbox, cl_object msg) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & - mailbox->mailbox.mask; - mailbox->mailbox.data->vector.self.t[ndx] = msg; - } - mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); - ecl_return0(env); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & + mailbox->mailbox.mask; + mailbox->mailbox.data->vector.self.t[ndx] = msg; + } + mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); + ecl_return0(env); } diff --git a/src/c/threads/mutex.d b/src/c/threads/mutex.d index cdd91a148..41a1cb419 100755 --- a/src/c/threads/mutex.d +++ b/src/c/threads/mutex.d @@ -46,58 +46,58 @@ FEerror_not_owned(cl_object lock) cl_object ecl_make_lock(cl_object name, bool recursive) { - cl_object output = ecl_alloc_object(t_lock); - output->lock.name = name; - output->lock.owner = ECL_NIL; - output->lock.counter = 0; - output->lock.recursive = recursive; - output->lock.queue_list = ECL_NIL; - output->lock.queue_spinlock = ECL_NIL; + cl_object output = ecl_alloc_object(t_lock); + output->lock.name = name; + output->lock.owner = ECL_NIL; + output->lock.counter = 0; + output->lock.recursive = recursive; + output->lock.queue_list = ECL_NIL; + output->lock.queue_spinlock = ECL_NIL; return output; } @(defun mp::make-lock (&key name ((:recursive recursive) ECL_NIL)) @ - @(return ecl_make_lock(name, !Null(recursive))) + @(return ecl_make_lock(name, !Null(recursive))) @) cl_object mp_recursive_lock_p(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) - FEerror_not_a_lock(lock); - ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); } cl_object mp_lock_name(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } ecl_return1(env, lock->lock.name); } cl_object mp_lock_owner(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } ecl_return1(env, lock->lock.owner); } cl_object mp_lock_count(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); } cl_object @@ -105,99 +105,99 @@ mp_giveup_lock(cl_object lock) { /* Must be called with interrupts disabled. */ cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - unlikely_if (lock->lock.owner != own_process) { + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + unlikely_if (lock->lock.owner != own_process) { FEerror_not_owned(lock); - } - if (--lock->lock.counter == 0) { - cl_object first = ecl_waiter_pop(env, lock);; - if (first == ECL_NIL) { - lock->lock.owner = ECL_NIL; - } else { - lock->lock.counter = 1; - lock->lock.owner = first; - ecl_wakeup_process(first); - } - } + } + if (--lock->lock.counter == 0) { + cl_object first = ecl_waiter_pop(env, lock);; + if (first == ECL_NIL) { + lock->lock.owner = ECL_NIL; + } else { + lock->lock.counter = 1; + lock->lock.owner = first; + ecl_wakeup_process(first); + } + } ecl_return1(env, ECL_T); } static cl_object get_lock_inner(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { unlikely_if (!lock->lock.recursive) { - FEerror_not_a_recursive_lock(lock); - } + FEerror_not_a_recursive_lock(lock); + } ++lock->lock.counter; - output = ECL_T; + output = ECL_T; } else { - print_lock("failed acquiring %p for %d\t", lock, lock, - lock->lock.owner); - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + print_lock("failed acquiring %p for %d\t", lock, lock, + lock->lock.owner); + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_nowait(cl_object lock) { cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, get_lock_inner(env, lock)); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, get_lock_inner(env, lock)); } static cl_object own_or_get_lock(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { - output = ECL_T; + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { + output = ECL_T; } else { - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_wait(cl_object lock) { cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - if (get_lock_inner(env, lock) == ECL_NIL) { - ecl_wait_on(env, own_or_get_lock, lock); - } - @(return ECL_T) + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + if (get_lock_inner(env, lock) == ECL_NIL) { + ecl_wait_on(env, own_or_get_lock, lock); + } + @(return ECL_T) } @(defun mp::get-lock (lock &optional (wait ECL_T)) @ - if (Null(wait)) - return mp_get_lock_nowait(lock); + if (Null(wait)) + return mp_get_lock_nowait(lock); else - return mp_get_lock_wait(lock); + return mp_get_lock_wait(lock); @) diff --git a/src/c/threads/process.d b/src/c/threads/process.d index f851481d9..2e6e7067e 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -14,7 +14,7 @@ */ #ifndef __sun__ /* See unixinit.d for this */ -#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ +#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ #endif #include #include @@ -60,13 +60,13 @@ cl_env_ptr ecl_process_env(void) { #ifdef ECL_WINDOWS_THREADS - return TlsGetValue(cl_env_key); + return TlsGetValue(cl_env_key); #else - struct cl_env_struct *rv = pthread_getspecific(cl_env_key); + struct cl_env_struct *rv = pthread_getspecific(cl_env_key); if (rv) - return rv; - FElibc_error("pthread_getspecific() failed.", 0); - return NULL; + return rv; + FElibc_error("pthread_getspecific() failed.", 0); + return NULL; #endif } #endif @@ -75,13 +75,13 @@ static void ecl_set_process_env(cl_env_ptr env) { #ifdef WITH___THREAD - cl_env_p = env; + cl_env_p = env; #else # ifdef ECL_WINDOWS_THREADS - TlsSetValue(cl_env_key, env); + TlsSetValue(cl_env_key, env); # else - if (pthread_setspecific(cl_env_key, env)) - FElibc_error("pthread_setcspecific() failed.", 0); + if (pthread_setspecific(cl_env_key, env)) + FElibc_error("pthread_setcspecific() failed.", 0); # endif #endif } @@ -89,7 +89,7 @@ ecl_set_process_env(cl_env_ptr env) cl_object mp_current_process(void) { - return ecl_process_env()->own_process; + return ecl_process_env()->own_process; } /*---------------------------------------------------------------------- @@ -99,79 +99,79 @@ mp_current_process(void) static void extend_process_vector() { - cl_object v = cl_core.processes; - cl_index new_size = v->vector.dim + v->vector.dim/2; - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object other = cl_core.processes; - if (new_size > other->vector.dim) { - cl_object new = si_make_vector(ECL_T, - ecl_make_fixnum(new_size), - ecl_make_fixnum(other->vector.fillp), - ECL_NIL, ECL_NIL, ECL_NIL); - ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; - } - } ECL_WITH_SPINLOCK_END; + cl_object v = cl_core.processes; + cl_index new_size = v->vector.dim + v->vector.dim/2; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object other = cl_core.processes; + if (new_size > other->vector.dim) { + cl_object new = si_make_vector(ECL_T, + ecl_make_fixnum(new_size), + ecl_make_fixnum(other->vector.fillp), + ECL_NIL, ECL_NIL, ECL_NIL); + ecl_copy_subarray(new, 0, other, 0, other->vector.dim); + cl_core.processes = new; + } + } ECL_WITH_SPINLOCK_END; } static void ecl_list_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - bool ok = 0; - do { - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index size = vector->vector.dim; - cl_index ndx = vector->vector.fillp; - if (ndx < size) { - vector->vector.self.t[ndx++] = process; - vector->vector.fillp = ndx; - ok = 1; - } - } ECL_WITH_SPINLOCK_END; - if (ok) break; - extend_process_vector(); - } while (1); + cl_env_ptr the_env = ecl_process_env(); + bool ok = 0; + do { + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index size = vector->vector.dim; + cl_index ndx = vector->vector.fillp; + if (ndx < size) { + vector->vector.self.t[ndx++] = process; + vector->vector.fillp = ndx; + ok = 1; + } + } ECL_WITH_SPINLOCK_END; + if (ok) break; + extend_process_vector(); + } while (1); } static void ecl_unlist_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - if (vector->vector.self.t[i] == process) { - vector->vector.fillp--; - do { - vector->vector.self.t[i] = - vector->vector.self.t[i+1]; - } while (++i < vector->vector.fillp); - break; - } - } - } ECL_WITH_SPINLOCK_END; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + if (vector->vector.self.t[i] == process) { + vector->vector.fillp--; + do { + vector->vector.self.t[i] = + vector->vector.self.t[i+1]; + } while (++i < vector->vector.fillp); + break; + } + } + } ECL_WITH_SPINLOCK_END; } static cl_object ecl_process_list() { - cl_env_ptr the_env = ecl_process_env(); - cl_object output = ECL_NIL; - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_object *data = vector->vector.self.t; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - cl_object p = data[i]; - if (p != ECL_NIL) - output = ecl_cons(p, output); - } - } ECL_WITH_SPINLOCK_END; - return output; + cl_env_ptr the_env = ecl_process_env(); + cl_object output = ECL_NIL; + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_object *data = vector->vector.self.t; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + cl_object p = data[i]; + if (p != ECL_NIL) + output = ecl_cons(p, output); + } + } ECL_WITH_SPINLOCK_END; + return output; } /*---------------------------------------------------------------------- @@ -181,42 +181,42 @@ ecl_process_list() static void assert_type_process(cl_object o) { - if (ecl_t_of(o) != t_process) - FEwrong_type_argument(@[mp::process], o); + if (ecl_t_of(o) != t_process) + FEwrong_type_argument(@[mp::process], o); } static void thread_cleanup(void *aux) { - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - cl_object process = (cl_object)aux; - cl_env_ptr env = process->process.env; - /* The following flags will disable all interrupts. */ + /* This routine performs some cleanup before a thread is completely + * killed. For instance, it has to remove the associated process + * object from the list, an it has to dealloc some memory. + * + * NOTE: thread_cleanup() does not provide enough "protection". In + * order to ensure that all UNWIND-PROTECT forms are properly + * executed, never use pthread_cancel() to kill a process, but + * rather use the lisp functions mp_interrupt_process() and + * mp_process_kill(). + */ + cl_object process = (cl_object)aux; + cl_env_ptr env = process->process.env; + /* The following flags will disable all interrupts. */ AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); - ecl_disable_interrupts_env(env); + ecl_disable_interrupts_env(env); #ifdef HAVE_SIGPROCMASK - /* ...but we might get stray signals. */ - { - sigset_t new[1]; - sigemptyset(new); - sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); - } + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_BLOCK, new, NULL); + } #endif - process->process.env = NULL; - ecl_unlist_process(process); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - ecl_set_process_env(NULL); - if (env) _ecl_dealloc_env(env); + process->process.env = NULL; + ecl_unlist_process(process); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + ecl_set_process_env(NULL); + if (env) _ecl_dealloc_env(env); AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE); } @@ -228,224 +228,224 @@ thread_entry_point(void *arg) #endif { cl_object process = (cl_object)arg; - cl_env_ptr env = process->process.env; + cl_env_ptr env = process->process.env; - /* - * Upon entering this routine - * process.env = our environment for lisp - * process.phase = ECL_PROCESS_BOOTING - * signals are disabled in the environment - * the communication interrupt is disabled (sigmasked) - * - * This process will not receive signals that originate from - * other processes. Furthermore, we expect not to get any - * other interrupts (SIGSEGV, SIGFPE) if we do things right. - */ - /* 1) Setup the environment for the execution of the thread */ - ecl_set_process_env(env = process->process.env); + /* + * Upon entering this routine + * process.env = our environment for lisp + * process.phase = ECL_PROCESS_BOOTING + * signals are disabled in the environment + * the communication interrupt is disabled (sigmasked) + * + * This process will not receive signals that originate from + * other processes. Furthermore, we expect not to get any + * other interrupts (SIGSEGV, SIGFPE) if we do things right. + */ + /* 1) Setup the environment for the execution of the thread */ + ecl_set_process_env(env = process->process.env); #ifndef ECL_WINDOWS_THREADS - pthread_cleanup_push(thread_cleanup, (void *)process); + pthread_cleanup_push(thread_cleanup, (void *)process); #endif - ecl_cs_set_org(env); - ecl_get_spinlock(env, &process->process.start_spinlock); - print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, - env->bds_org, env->bds_top, env->bds_limit); + ecl_cs_set_org(env); + ecl_get_spinlock(env, &process->process.start_spinlock); + print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, + env->bds_org, env->bds_top, env->bds_limit); - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - ECL_CATCH_ALL_BEGIN(env) { + /* 2) Execute the code. The CATCH_ALL point is the destination + * provides us with an elegant way to exit the thread: we just + * do an unwind up to frs_top. + */ + ECL_CATCH_ALL_BEGIN(env) { #ifdef HAVE_SIGPROCMASK - { - sigset_t *new = (sigset_t*)env->default_sigmask; - pthread_sigmask(SIG_SETMASK, new, NULL); - } + { + sigset_t *new = (sigset_t*)env->default_sigmask; + pthread_sigmask(SIG_SETMASK, new, NULL); + } #endif - process->process.phase = ECL_PROCESS_ACTIVE; - ecl_enable_interrupts_env(env); - si_trap_fpe(@'last', ECL_T); - ecl_bds_bind(env, @'mp::*current-process*', process); + process->process.phase = ECL_PROCESS_ACTIVE; + ecl_enable_interrupts_env(env); + si_trap_fpe(@'last', ECL_T); + ecl_bds_bind(env, @'mp::*current-process*', process); - ECL_RESTART_CASE_BEGIN(env, @'abort') { - env->values[0] = cl_apply(2, process->process.function, - process->process.args); - { - cl_object output = ECL_NIL; - int i = env->nvalues; - while (i--) { - output = CONS(env->values[i], output); - } - process->process.exit_values = output; - } - } ECL_RESTART_CASE(1,args) { - /* ABORT restart. */ - process->process.exit_values = args; - } ECL_RESTART_CASE_END; - /* This will disable interrupts during the exit - * so that the unwinding is not interrupted. */ - process->process.phase = ECL_PROCESS_EXITING; - ecl_bds_unwind1(env); - } ECL_CATCH_ALL_END; + ECL_RESTART_CASE_BEGIN(env, @'abort') { + env->values[0] = cl_apply(2, process->process.function, + process->process.args); + { + cl_object output = ECL_NIL; + int i = env->nvalues; + while (i--) { + output = CONS(env->values[i], output); + } + process->process.exit_values = output; + } + } ECL_RESTART_CASE(1,args) { + /* ABORT restart. */ + process->process.exit_values = args; + } ECL_RESTART_CASE_END; + /* This will disable interrupts during the exit + * so that the unwinding is not interrupted. */ + process->process.phase = ECL_PROCESS_EXITING; + ecl_bds_unwind1(env); + } ECL_CATCH_ALL_END; - /* 4) If everything went right, we should be exiting the thread - * through this point. thread_cleanup is automatically invoked - * marking the process as inactive. - */ + /* 4) If everything went right, we should be exiting the thread + * through this point. thread_cleanup is automatically invoked + * marking the process as inactive. + */ #ifdef ECL_WINDOWS_THREADS - thread_cleanup(process); - return 1; + thread_cleanup(process); + return 1; #else - pthread_cleanup_pop(1); - return NULL; + pthread_cleanup_pop(1); + return NULL; #endif } static cl_object alloc_process(cl_object name, cl_object initial_bindings) { - cl_object process = ecl_alloc_object(t_process), array; + cl_object process = ecl_alloc_object(t_process), array; process->process.phase = ECL_PROCESS_INACTIVE; - process->process.name = name; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.interrupt = ECL_NIL; + process->process.name = name; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.interrupt = ECL_NIL; process->process.exit_values = ECL_NIL; - process->process.env = NULL; - if (initial_bindings != OBJNULL) { - array = si_make_vector(ECL_T, ecl_make_fixnum(256), + process->process.env = NULL; + if (initial_bindings != OBJNULL) { + array = si_make_vector(ECL_T, ecl_make_fixnum(256), ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - } else { - array = cl_copy_seq(ecl_process_env()->bindings_array); - } + } else { + array = cl_copy_seq(ecl_process_env()->bindings_array); + } process->process.initial_bindings = array; - process->process.woken_up = ECL_NIL; - process->process.start_spinlock = ECL_NIL; - process->process.queue_record = ecl_list1(process); - /* Creates the exit barrier so that processes can wait for termination, - * but it is created in a disabled state. */ - process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - return process; + process->process.woken_up = ECL_NIL; + process->process.start_spinlock = ECL_NIL; + process->process.queue_record = ecl_list1(process); + /* Creates the exit barrier so that processes can wait for termination, + * but it is created in a disabled state. */ + process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + return process; } bool ecl_import_current_thread(cl_object name, cl_object bindings) { - struct cl_env_struct env_aux[1]; - cl_object process; - pthread_t current; - cl_env_ptr env; - int registered; - struct GC_stack_base stack; + struct cl_env_struct env_aux[1]; + cl_object process; + pthread_t current; + cl_env_ptr env; + int registered; + struct GC_stack_base stack; #ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - ¤t, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - CloseHandle(current); - } + { + HANDLE aux = GetCurrentThread(); + DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + ¤t, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + CloseHandle(current); + } #else - current = pthread_self(); + current = pthread_self(); #endif #ifdef GBC_BOEHM - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks - * for thread creation */ - registered = 0; - break; - default: - return 0; - } + GC_get_stack_base(&stack); + switch (GC_register_my_thread(&stack)) { + case GC_SUCCESS: + registered = 1; + break; + case GC_DUPLICATE: + /* Thread was probably created using the GC hooks + * for thread creation */ + registered = 0; + break; + default: + return 0; + } #endif - { - cl_object processes = cl_core.processes; - cl_index i, size; - for (i = 0, size = processes->vector.dim; i < size; i++) { - cl_object p = processes->vector.self.t[i]; - if (!Null(p) && p->process.thread == current) - return 0; - } - } - /* We need a fake env to allow for interrupts blocking. */ - env_aux->disable_interrupts = 1; - ecl_set_process_env(env_aux); - env = _ecl_alloc_env(0); - ecl_set_process_env(env); - env->cleanup = registered; + { + cl_object processes = cl_core.processes; + cl_index i, size; + for (i = 0, size = processes->vector.dim; i < size; i++) { + cl_object p = processes->vector.self.t[i]; + if (!Null(p) && p->process.thread == current) + return 0; + } + } + /* We need a fake env to allow for interrupts blocking. */ + env_aux->disable_interrupts = 1; + ecl_set_process_env(env_aux); + env = _ecl_alloc_env(0); + ecl_set_process_env(env); + env->cleanup = registered; - /* Link environment and process together */ - env->own_process = process = alloc_process(name, bindings); - process->process.env = env; + /* Link environment and process together */ + env->own_process = process = alloc_process(name, bindings); + process->process.env = env; process->process.phase = ECL_PROCESS_BOOTING; - process->process.thread = current; - ecl_list_process(process); + process->process.thread = current; + ecl_list_process(process); - ecl_init_env(env); - env->bindings_array = process->process.initial_bindings; + ecl_init_env(env); + env->bindings_array = process->process.initial_bindings; env->thread_local_bindings_size = env->bindings_array->vector.dim; env->thread_local_bindings = env->bindings_array->vector.self.t; - ecl_enable_interrupts_env(env); + ecl_enable_interrupts_env(env); - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); process->process.phase = ECL_PROCESS_ACTIVE; - ecl_bds_bind(env, @'mp::*current-process*', process); - return 1; + ecl_bds_bind(env, @'mp::*current-process*', process); + return 1; } void ecl_release_current_thread(void) { - cl_env_ptr env = ecl_process_env(); - int cleanup = env->cleanup; - thread_cleanup(env->own_process); + cl_env_ptr env = ecl_process_env(); + int cleanup = env->cleanup; + thread_cleanup(env->own_process); #ifdef GBC_BOEHM - if (cleanup) { - GC_unregister_my_thread(); - } + if (cleanup) { + GC_unregister_my_thread(); + } #endif } @(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T)) - cl_object process; + cl_object process; @ - process = alloc_process(name, initial_bindings); - @(return process) + process = alloc_process(name, initial_bindings); + @(return process) @) cl_object mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) { - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-preset]); - assert_type_process(process); - process->process.function = function; - process->process.args = cl_grab_rest_args(args); - @(return process) + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-preset]); + assert_type_process(process); + process->process.function = function; + process->process.args = cl_grab_rest_args(args); + @(return process) } cl_object mp_interrupt_process(cl_object process, cl_object function) { - unlikely_if (mp_process_active_p(process) == ECL_NIL) - FEerror("Cannot interrupt the inactive process ~A", 1, process); + unlikely_if (mp_process_active_p(process) == ECL_NIL) + FEerror("Cannot interrupt the inactive process ~A", 1, process); ecl_interrupt_process(process, function); - @(return ECL_T) + @(return ECL_T) } cl_object @@ -457,7 +457,7 @@ mp_suspend_loop() cl_sleep(ecl_make_fixnum(100)); } } ECL_CATCH_END; - ecl_return0(env); + ecl_return0(env); } cl_object @@ -467,7 +467,7 @@ mp_break_suspend_loop() if (frs_sch(@'mp::suspend-loop')) { cl_throw(@'mp::suspend-loop'); } - ecl_return0(the_env); + ecl_return0(the_env); } cl_object @@ -485,183 +485,183 @@ mp_process_resume(cl_object process) cl_object mp_process_kill(cl_object process) { - return mp_interrupt_process(process, @'mp::exit-process'); + return mp_interrupt_process(process, @'mp::exit-process'); } cl_object mp_process_yield(void) { - ecl_process_yield(); - @(return) + ecl_process_yield(); + @(return) } cl_object mp_process_enable(cl_object process) { - cl_env_ptr process_env; - int ok; - /* Try to gain exclusive access to the process at the same - * time we ensure that it is inactive. This prevents two - * concurrent calls to process-enable from different threads - * on the same process */ - unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, - ECL_PROCESS_INACTIVE, - ECL_PROCESS_BOOTING)) { - FEerror("Cannot enable the running process ~A.", 1, process); - } + cl_env_ptr process_env; + int ok; + /* Try to gain exclusive access to the process at the same + * time we ensure that it is inactive. This prevents two + * concurrent calls to process-enable from different threads + * on the same process */ + unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, + ECL_PROCESS_INACTIVE, + ECL_PROCESS_BOOTING)) { + FEerror("Cannot enable the running process ~A.", 1, process); + } process->process.parent = mp_current_process(); - process->process.trap_fpe_bits = - process->process.parent->process.env->trap_fpe_bits; - ecl_list_process(process); + process->process.trap_fpe_bits = + process->process.parent->process.env->trap_fpe_bits; + ecl_list_process(process); - /* Link environment and process together */ - process_env = _ecl_alloc_env(ecl_process_env()); - process_env->own_process = process; - process->process.env = process_env; + /* Link environment and process together */ + process_env = _ecl_alloc_env(ecl_process_env()); + process_env->own_process = process; + process->process.env = process_env; - ecl_init_env(process_env); - process_env->trap_fpe_bits = process->process.trap_fpe_bits; - process_env->bindings_array = process->process.initial_bindings; + ecl_init_env(process_env); + process_env->trap_fpe_bits = process->process.trap_fpe_bits; + process_env->bindings_array = process->process.initial_bindings; process_env->thread_local_bindings_size = process_env->bindings_array->vector.dim; process_env->thread_local_bindings = process_env->bindings_array->vector.self.t; - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); - /* Block the thread with this spinlock until it is ready */ - process->process.start_spinlock = ECL_T; + /* Block the thread with this spinlock until it is ready */ + process->process.start_spinlock = ECL_T; #ifdef ECL_WINDOWS_THREADS - { - HANDLE code; - DWORD threadId; + { + HANDLE code; + DWORD threadId; - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process->process.thread = code) != NULL; - } + code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); + ok = (process->process.thread = code) != NULL; + } #else - { - int code; + { + int code; pthread_attr_t pthreadattr; - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * We launch the thread with the signal mask specified in cl_core. - * The reason is that we might need to block certain signals - * to be processed by the signal handling thread in unixint.d - */ + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + /* + * We launch the thread with the signal mask specified in cl_core. + * The reason is that we might need to block certain signals + * to be processed by the signal handling thread in unixint.d + */ #ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } + { + sigset_t new, previous; + sigfillset(&new); + pthread_sigmask(SIG_BLOCK, &new, &previous); + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); + pthread_sigmask(SIG_SETMASK, &previous, NULL); + } #else - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); #endif - ok = (code == 0); - } + ok = (code == 0); + } #endif - if (!ok) { - ecl_unlist_process(process); - /* Disable the barrier and alert possible waiting processes. */ - mp_barrier_unblock(3, process->process.exit_barrier, - @':disable', ECL_T); - process->process.phase = ECL_PROCESS_INACTIVE; - process->process.env = NULL; - _ecl_dealloc_env(process_env); - } - /* Unleash the thread */ - process->process.start_spinlock = ECL_NIL; + if (!ok) { + ecl_unlist_process(process); + /* Disable the barrier and alert possible waiting processes. */ + mp_barrier_unblock(3, process->process.exit_barrier, + @':disable', ECL_T); + process->process.phase = ECL_PROCESS_INACTIVE; + process->process.env = NULL; + _ecl_dealloc_env(process_env); + } + /* Unleash the thread */ + process->process.start_spinlock = ECL_NIL; - @(return (ok? process : ECL_NIL)) + @(return (ok? process : ECL_NIL)) } cl_object mp_exit_process(void) { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ - const cl_env_ptr the_env = ecl_process_env(); - ecl_unwind(the_env, the_env->frs_org); - /* Never reached */ + /* We simply undo the whole of the frame stack. This brings up + back to the thread entry point, going through all possible + UNWIND-PROTECT. + */ + const cl_env_ptr the_env = ecl_process_env(); + ecl_unwind(the_env, the_env->frs_org); + /* Never reached */ } cl_object mp_all_processes(void) { - /* No race condition here because this list is never destructively - * modified. When we add or remove processes, we create new lists. */ - @(return ecl_process_list()) + /* No race condition here because this list is never destructively + * modified. When we add or remove processes, we create new lists. */ + @(return ecl_process_list()) } cl_object mp_process_name(cl_object process) { - assert_type_process(process); - @(return process->process.name) + assert_type_process(process); + @(return process->process.name) } cl_object mp_process_active_p(cl_object process) { - assert_type_process(process); - @(return (process->process.phase? ECL_T : ECL_NIL)) + assert_type_process(process); + @(return (process->process.phase? ECL_T : ECL_NIL)) } cl_object mp_process_whostate(cl_object process) { - assert_type_process(process); - @(return (cl_core.null_string)) + assert_type_process(process); + @(return (cl_core.null_string)) } cl_object mp_process_join(cl_object process) { - assert_type_process(process); - if (process->process.phase) { - /* We try to acquire a lock that is only owned by the process - * while it is active. */ - mp_barrier_wait(1, process->process.exit_barrier); - } + assert_type_process(process); + if (process->process.phase) { + /* We try to acquire a lock that is only owned by the process + * while it is active. */ + mp_barrier_wait(1, process->process.exit_barrier); + } return cl_values_list(process->process.exit_values); } cl_object mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-run-function]); - if (CONSP(name)) { - process = cl_apply(2, @'mp::make-process', name); - } else { - process = mp_make_process(2, @':name', name); - } - cl_apply(4, @'mp::process-preset', process, function, - cl_grab_rest_args(args)); - return mp_process_enable(process); + cl_object process; + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-run-function]); + if (CONSP(name)) { + process = cl_apply(2, @'mp::make-process', name); + } else { + process = mp_make_process(2, @':name', name); + } + cl_apply(4, @'mp::process-preset', process, function, + cl_grab_rest_args(args)); + return mp_process_enable(process); } cl_object mp_process_run_function_wait(cl_narg narg, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - process = cl_apply(2, @'mp::process-run-function', + cl_object process; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + process = cl_apply(2, @'mp::process-run-function', cl_grab_rest_args(args)); if (!Null(process)) { ecl_def_ct_single_float(wait, 0.001, static, const); @@ -669,7 +669,7 @@ mp_process_run_function_wait(cl_narg narg, ...) cl_sleep(wait); } } - @(return process) + @(return process) } /*---------------------------------------------------------------------- @@ -737,60 +737,60 @@ mp_restore_signals(cl_object sigmask) void init_threads(cl_env_ptr env) { - cl_object process; - pthread_t main_thread; + cl_object process; + pthread_t main_thread; - cl_core.processes = OBJNULL; + cl_core.processes = OBJNULL; - /* We have to set the environment before any allocation takes place, - * so that the interrupt handling code works. */ + /* We have to set the environment before any allocation takes place, + * so that the interrupt handling code works. */ #if !defined(WITH___THREAD) # if defined(ECL_WINDOWS_THREADS) - cl_env_key = TlsAlloc(); + cl_env_key = TlsAlloc(); # else - pthread_key_create(&cl_env_key, NULL); + pthread_key_create(&cl_env_key, NULL); # endif #endif - ecl_set_process_env(env); + ecl_set_process_env(env); #ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - &main_thread, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - } + { + HANDLE aux = GetCurrentThread(); + DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + &main_thread, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + } #else - main_thread = pthread_self(); + main_thread = pthread_self(); #endif - process = ecl_alloc_object(t_process); - process->process.phase = ECL_PROCESS_ACTIVE; - process->process.name = @'si::top-level'; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.thread = main_thread; - process->process.env = env; - process->process.woken_up = ECL_NIL; - process->process.queue_record = ecl_list1(process); - process->process.start_spinlock = ECL_NIL; - process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); + process = ecl_alloc_object(t_process); + process->process.phase = ECL_PROCESS_ACTIVE; + process->process.name = @'si::top-level'; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.thread = main_thread; + process->process.env = env; + process->process.woken_up = ECL_NIL; + process->process.queue_record = ecl_list1(process); + process->process.start_spinlock = ECL_NIL; + process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); - env->own_process = process; + env->own_process = process; - { - cl_object v = si_make_vector(ECL_T, /* Element type */ - ecl_make_fixnum(256), /* Size */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, ECL_NIL, ECL_NIL); - v->vector.self.t[0] = process; - v->vector.fillp = 1; - cl_core.processes = v; - cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); - cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); - cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); - } + { + cl_object v = si_make_vector(ECL_T, /* Element type */ + ecl_make_fixnum(256), /* Size */ + ecl_make_fixnum(0), /* fill pointer */ + ECL_NIL, ECL_NIL, ECL_NIL); + v->vector.self.t[0] = process; + v->vector.fillp = 1; + cl_core.processes = v; + cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); + cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); + cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); + } } diff --git a/src/c/threads/queue.d b/src/c/threads/queue.d index 7aad83b00..2d17ea326 100755 --- a/src/c/threads/queue.d +++ b/src/c/threads/queue.d @@ -25,59 +25,59 @@ void ECL_INLINE ecl_process_yield() { #if defined(ECL_WINDOWS_THREADS) - Sleep(0); + Sleep(0); #elif defined(HAVE_SCHED_H) - sched_yield(); + sched_yield(); #else - ecl_musleep(0.0, 1);*/ + ecl_musleep(0.0, 1);*/ #endif } void ECL_INLINE ecl_get_spinlock(cl_env_ptr the_env, cl_object *lock) { - cl_object own_process = the_env->own_process; - while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, - (AO_t)own_process)) { - ecl_process_yield(); - } + cl_object own_process = the_env->own_process; + while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, + (AO_t)own_process)) { + ecl_process_yield(); + } } void ECL_INLINE ecl_giveup_spinlock(cl_object *lock) { - AO_store((AO_t*)lock, (AO_t)ECL_NIL); + AO_store((AO_t*)lock, (AO_t)ECL_NIL); } static ECL_INLINE void wait_queue_nconc(cl_env_ptr the_env, cl_object q, cl_object new_tail) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_nconc(q->queue.list, new_tail); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_nconc(q->queue.list, new_tail); + ecl_giveup_spinlock(&q->queue.spinlock); } static ECL_INLINE cl_object wait_queue_pop_all(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - { - ecl_get_spinlock(the_env, &q->queue.spinlock); - output = q->queue.list; - q->queue.list = ECL_NIL; - ecl_giveup_spinlock(&q->queue.spinlock); - } - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + { + ecl_get_spinlock(the_env, &q->queue.spinlock); + output = q->queue.list; + q->queue.list = ECL_NIL; + ecl_giveup_spinlock(&q->queue.spinlock); + } + ecl_enable_interrupts_env(the_env); + return output; } static ECL_INLINE void wait_queue_delete(cl_env_ptr the_env, cl_object q, cl_object item) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_delete_eq(item, q->queue.list); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_delete_eq(item, q->queue.list); + ecl_giveup_spinlock(&q->queue.spinlock); } /*---------------------------------------------------------------------- @@ -87,112 +87,112 @@ wait_queue_delete(cl_env_ptr the_env, cl_object q, cl_object item) static cl_object bignum_set_time(cl_object bignum, struct ecl_timeval *time) { - _ecl_big_set_index(bignum, time->tv_sec); - _ecl_big_mul_ui(bignum, bignum, 1000); - _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); - return bignum; + _ecl_big_set_index(bignum, time->tv_sec); + _ecl_big_mul_ui(bignum, bignum, 1000); + _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); + return bignum; } static cl_object elapsed_time(struct ecl_timeval *start) { - cl_object delta_big = _ecl_big_register0(); - cl_object aux_big = _ecl_big_register1(); - struct ecl_timeval now; - ecl_get_internal_real_time(&now); - bignum_set_time(aux_big, start); - bignum_set_time(delta_big, &now); - _ecl_big_sub(delta_big, delta_big, aux_big); - _ecl_big_register_free(aux_big); - return delta_big; + cl_object delta_big = _ecl_big_register0(); + cl_object aux_big = _ecl_big_register1(); + struct ecl_timeval now; + ecl_get_internal_real_time(&now); + bignum_set_time(aux_big, start); + bignum_set_time(delta_big, &now); + _ecl_big_sub(delta_big, delta_big, aux_big); + _ecl_big_register_free(aux_big); + return delta_big; } static double waiting_time(cl_index iteration, struct ecl_timeval *start) { - /* Waiting time is smaller than 0.10 s */ - double time; - cl_object top = ecl_make_fixnum(10 * 1000); - cl_object delta_big = elapsed_time(start); - _ecl_big_div_ui(delta_big, delta_big, iteration); - if (ecl_number_compare(delta_big, top) < 0) { - time = ecl_to_double(delta_big) * 1.5; - } else { - time = 0.10; - } - _ecl_big_register_free(delta_big); - return time; + /* Waiting time is smaller than 0.10 s */ + double time; + cl_object top = ecl_make_fixnum(10 * 1000); + cl_object delta_big = elapsed_time(start); + _ecl_big_div_ui(delta_big, delta_big, iteration); + if (ecl_number_compare(delta_big, top) < 0) { + time = ecl_to_double(delta_big) * 1.5; + } else { + time = 0.10; + } + _ecl_big_register_free(delta_big); + return time; } static cl_object ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile cl_object output; - cl_fixnum iteration = 0; - struct ecl_timeval start; - ecl_get_internal_real_time(&start); + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile cl_object output; + cl_fixnum iteration = 0; + struct ecl_timeval start; + ecl_get_internal_real_time(&start); - /* This spinlock is here because the default path (fair) is - * too slow */ - for (iteration = 0; iteration < 10; iteration++) { - cl_object output = condition(the_env,o); - if (output != ECL_NIL) - return output; - } + /* This spinlock is here because the default path (fair) is + * too slow */ + for (iteration = 0; iteration < 10; iteration++) { + cl_object output = condition(the_env,o); + if (output != ECL_NIL) + return output; + } - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 2) Now we add ourselves to the queue. In order to - * avoid a call to the GC, we try to reuse records. */ - print_lock("adding to queue", o); - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); - ecl_check_pending_interrupts(the_env); + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 2) Now we add ourselves to the queue. In order to + * avoid a call to the GC, we try to reuse records. */ + print_lock("adding to queue", o); + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); + ecl_check_pending_interrupts(the_env); - /* 3) Unlike the sigsuspend() implementation, this - * implementation does not block signals and the - * wakeup event might be lost before the sleep - * function is invoked. We must thus spin over short - * intervals of time to ensure that we check the - * condition periodically. */ - while (Null(output = condition(the_env, o))) { - ecl_musleep(waiting_time(iteration++, &start), 1); - } - ecl_bds_unwind1(the_env); - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); + /* 3) Unlike the sigsuspend() implementation, this + * implementation does not block signals and the + * wakeup event might be lost before the sleep + * function is invoked. We must thus spin over short + * intervals of time to ensure that we check the + * condition periodically. */ + while (Null(output = condition(the_env, o))) { + ecl_musleep(waiting_time(iteration++, &start), 1); + } + ecl_bds_unwind1(the_env); + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } - } ECL_UNWIND_PROTECT_END; - ecl_bds_unwind1(the_env); - return output; + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } + } ECL_UNWIND_PROTECT_END; + ecl_bds_unwind1(the_env); + return output; } /********************************************************************** @@ -201,9 +201,9 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), * This object keeps a list of processes waiting for a condition to * happen. The queue is ordered and the only processes that check for * the condition are - * - The first process to arrive to the queue, - * - Each process which is awoken. - * - The first process after the list of awoken processes. + * - The first process to arrive to the queue, + * - Each process which is awoken. + * - The first process after the list of awoken processes. * * The idea is that this will ensure some fairness when unblocking the * processes, which is important for abstractions such as mutexes or @@ -211,12 +211,12 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), * * This also implies that the waiting processes depend on others to signal * when to check for a condition. This happens in two situations - * - External code that changes the fields of the queue object - * must signal ecl_wakeup_waiters() (See mutex.d, semaphore.d, etc) - * - When a process exits ecl_wait_on() it always resignals the next - * process in the queue, because a condition may be satisfied more - * than once (for instance when a semaphore is changed, more than - * one process may be released) + * - External code that changes the fields of the queue object + * must signal ecl_wakeup_waiters() (See mutex.d, semaphore.d, etc) + * - When a process exits ecl_wait_on() it always resignals the next + * process in the queue, because a condition may be satisfied more + * than once (for instance when a semaphore is changed, more than + * one process may be released) * * The critical part of this algorithm is the fact that processes * communicating the change of conditions may do so before, during or @@ -228,140 +228,140 @@ cl_object ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { #if defined(HAVE_SIGPROCMASK) - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile sigset_t original; - volatile cl_object output; + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile sigset_t original; + volatile cl_object output; - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } - /* 1) First we block lisp interrupt signals. This ensures that - * any awake signal that is issued from here is not lost. */ - { - int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - sigset_t empty; - sigemptyset(&empty); - sigaddset(&empty, code); - pthread_sigmask(SIG_BLOCK, &empty, &original); - } + /* 1) First we block lisp interrupt signals. This ensures that + * any awake signal that is issued from here is not lost. */ + { + int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + sigset_t empty; + sigemptyset(&empty); + sigaddset(&empty, code); + pthread_sigmask(SIG_BLOCK, &empty, &original); + } - /* 2) Now we add ourselves to the queue. */ - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); + /* 2) Now we add ourselves to the queue. */ + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 3) At this point we may receive signals, but we - * might have missed a wakeup event if that happened - * between 0) and 2), which is why we start with the - * check*/ - while (Null(output = condition(the_env, o))) - { - /* This will wait until we get a signal that - * demands some code being executed. Note that - * this includes our communication signals and - * the signals used by the GC. Note also that - * as a consequence we might throw / return - * which is why need to protect it all with - * UNWIND-PROTECT. */ - sigsuspend(&original); - } - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 3) At this point we may receive signals, but we + * might have missed a wakeup event if that happened + * between 0) and 2), which is why we start with the + * check*/ + while (Null(output = condition(the_env, o))) + { + /* This will wait until we get a signal that + * demands some code being executed. Note that + * this includes our communication signals and + * the signals used by the GC. Note also that + * as a consequence we might throw / return + * which is why need to protect it all with + * UNWIND-PROTECT. */ + sigsuspend(&original); + } + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } - /* 6) Restoring signals is done last, to ensure that - * all cleanup steps are performed. */ - pthread_sigmask(SIG_SETMASK, &original, NULL); - } ECL_UNWIND_PROTECT_END; - return output; + /* 6) Restoring signals is done last, to ensure that + * all cleanup steps are performed. */ + pthread_sigmask(SIG_SETMASK, &original, NULL); + } ECL_UNWIND_PROTECT_END; + return output; #else - return ecl_wait_on_timed(env, condition, o); + return ecl_wait_on_timed(env, condition, o); #endif } cl_object ecl_waiter_pop(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - { - cl_object l; - output = ECL_NIL; - for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase != ECL_PROCESS_INACTIVE && - p->process.phase != ECL_PROCESS_EXITING) { - output = p; - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + { + cl_object l; + output = ECL_NIL; + for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase != ECL_PROCESS_INACTIVE && + p->process.phase != ECL_PROCESS_EXITING) { + output = p; + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) { - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - if (q->queue.list != ECL_NIL) { - /* We scan the list of waiting processes, awaking one - * or more, depending on flags. In running through the list - * we eliminate zombie processes --- they should not be here - * because of the UNWIND-PROTECT in ecl_wait_on(), but - * sometimes shit happens */ - cl_object *tail, l; - for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase == ECL_PROCESS_INACTIVE || - p->process.phase == ECL_PROCESS_EXITING) { - print_lock("removing %p", q, p); - *tail = ECL_CONS_CDR(l); - } else { - print_lock("awaking %p", q, p); - /* If the process is active, we then - * simply awake it with a signal.*/ - p->process.woken_up = ECL_T; - if (flags & ECL_WAKEUP_DELETE) - *tail = ECL_CONS_CDR(l); - tail = &ECL_CONS_CDR(l); - if (flags & ECL_WAKEUP_KILL) - mp_process_kill(p); - else - ecl_wakeup_process(p); - if (!(flags & ECL_WAKEUP_ALL)) - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_process_yield(); + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + if (q->queue.list != ECL_NIL) { + /* We scan the list of waiting processes, awaking one + * or more, depending on flags. In running through the list + * we eliminate zombie processes --- they should not be here + * because of the UNWIND-PROTECT in ecl_wait_on(), but + * sometimes shit happens */ + cl_object *tail, l; + for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase == ECL_PROCESS_INACTIVE || + p->process.phase == ECL_PROCESS_EXITING) { + print_lock("removing %p", q, p); + *tail = ECL_CONS_CDR(l); + } else { + print_lock("awaking %p", q, p); + /* If the process is active, we then + * simply awake it with a signal.*/ + p->process.woken_up = ECL_T; + if (flags & ECL_WAKEUP_DELETE) + *tail = ECL_CONS_CDR(l); + tail = &ECL_CONS_CDR(l); + if (flags & ECL_WAKEUP_KILL) + mp_process_kill(p); + else + ecl_wakeup_process(p); + if (!(flags & ECL_WAKEUP_ALL)) + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_process_yield(); } #undef print_lock @@ -369,25 +369,25 @@ ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) void print_lock(char *prefix, cl_object l, ...) { - static cl_object lock = ECL_NIL; - va_list args; - va_start(args, l); - if (l == ECL_NIL - || type_of(l) == t_condition_variable - || ECL_FIXNUMP(l->lock.name)) { - cl_env_ptr env = ecl_process_env(); - ecl_get_spinlock(env, &lock); - printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); - vprintf(prefix, args); - if (l != ECL_NIL) { - cl_object p = l->lock.queue_list; - while (p != ECL_NIL) { - printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); - p = ECL_CONS_CDR(p); - } - } - fflush(stdout); - ecl_giveup_spinlock(&lock); - } + static cl_object lock = ECL_NIL; + va_list args; + va_start(args, l); + if (l == ECL_NIL + || type_of(l) == t_condition_variable + || ECL_FIXNUMP(l->lock.name)) { + cl_env_ptr env = ecl_process_env(); + ecl_get_spinlock(env, &lock); + printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); + vprintf(prefix, args); + if (l != ECL_NIL) { + cl_object p = l->lock.queue_list; + while (p != ECL_NIL) { + printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); + p = ECL_CONS_CDR(p); + } + } + fflush(stdout); + ecl_giveup_spinlock(&lock); + } } /*#define print_lock(a,b,c) (void)0*/ diff --git a/src/c/threads/rwlock.d b/src/c/threads/rwlock.d index d251fa691..639ee5095 100644 --- a/src/c/threads/rwlock.d +++ b/src/c/threads/rwlock.d @@ -14,7 +14,7 @@ */ #ifndef __sun__ /* See unixinit.d for this */ -#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ +#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ #endif #include #include @@ -68,34 +68,34 @@ cl_object ecl_make_rwlock(cl_object name) { const cl_env_ptr the_env = ecl_process_env(); - cl_object output = ecl_alloc_object(t_rwlock); + cl_object output = ecl_alloc_object(t_rwlock); #ifdef ECL_RWLOCK int rc; - ecl_disable_interrupts_env(the_env); - rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); - ecl_enable_interrupts_env(the_env); + ecl_disable_interrupts_env(the_env); + rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); + ecl_enable_interrupts_env(the_env); if (rc) { FEerror("Unable to create read/write lock", 0); } - ecl_set_finalizer_unprotected(output, ECL_T); + ecl_set_finalizer_unprotected(output, ECL_T); #else output->rwlock.mutex = ecl_make_lock(name, 0); #endif - output->rwlock.name = name; + output->rwlock.name = name; return output; } @(defun mp::make-rwlock (&key name) @ - @(return ecl_make_rwlock(name)) + @(return ecl_make_rwlock(name)) @) cl_object mp_rwlock_name(cl_object lock) { - const cl_env_ptr env = ecl_process_env(); - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + const cl_env_ptr env = ecl_process_env(); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); ecl_return1(env, lock->rwlock.name); } @@ -103,8 +103,8 @@ cl_object mp_giveup_rwlock_read(cl_object lock) { /* Must be called with interrupts disabled. */ - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK { int rc = pthread_rwlock_unlock(&lock->rwlock.mutex); @@ -120,14 +120,14 @@ mp_giveup_rwlock_read(cl_object lock) cl_object mp_giveup_rwlock_write(cl_object lock) { - return mp_giveup_rwlock_read(lock); + return mp_giveup_rwlock_read(lock); } cl_object mp_get_rwlock_read_nowait(cl_object lock) { if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK { const cl_env_ptr env = ecl_process_env(); @@ -151,7 +151,7 @@ cl_object mp_get_rwlock_read_wait(cl_object lock) { if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK { const cl_env_ptr env = ecl_process_env(); @@ -168,17 +168,17 @@ mp_get_rwlock_read_wait(cl_object lock) @(defun mp::get-rwlock-read (lock &optional (wait ECL_T)) @ - if (Null(wait)) - return mp_get_rwlock_read_nowait(lock); + if (Null(wait)) + return mp_get_rwlock_read_nowait(lock); else - return mp_get_rwlock_read_wait(lock); + return mp_get_rwlock_read_wait(lock); @) cl_object mp_get_rwlock_write_nowait(cl_object lock) { if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK { const cl_env_ptr env = ecl_process_env(); @@ -203,7 +203,7 @@ mp_get_rwlock_write_wait(cl_object lock) { cl_env_ptr env = ecl_process_env(); if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK { int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex); @@ -219,8 +219,8 @@ mp_get_rwlock_write_wait(cl_object lock) @(defun mp::get-rwlock-write (lock &optional (wait ECL_T)) @ - if (Null(wait)) - return mp_get_rwlock_write_nowait(lock); + if (Null(wait)) + return mp_get_rwlock_write_nowait(lock); else - return mp_get_rwlock_write_wait(lock); + return mp_get_rwlock_write_wait(lock); @) diff --git a/src/c/threads/semaphore.d b/src/c/threads/semaphore.d index 023735e77..ccd4bf21b 100644 --- a/src/c/threads/semaphore.d +++ b/src/c/threads/semaphore.d @@ -30,63 +30,63 @@ FEerror_not_a_semaphore(cl_object semaphore) cl_object ecl_make_semaphore(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_semaphore); - output->semaphore.name = name; - output->semaphore.counter = count; - output->semaphore.queue_list = ECL_NIL; - output->semaphore.queue_spinlock = ECL_NIL; + cl_object output = ecl_alloc_object(t_semaphore); + output->semaphore.name = name; + output->semaphore.counter = count; + output->semaphore.queue_list = ECL_NIL; + output->semaphore.queue_spinlock = ECL_NIL; return output; } @(defun mp::make-semaphore (&key name (count ecl_make_fixnum(0))) @ { - @(return ecl_make_semaphore(name, fixnnint(count))) + @(return ecl_make_semaphore(name, fixnnint(count))) } @) cl_object mp_semaphore_name(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } ecl_return1(env, semaphore->semaphore.name); } cl_object mp_semaphore_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); } cl_object mp_semaphore_wait_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); } @(defun mp::signal-semaphore (semaphore &optional (count ecl_make_fixnum(1))) @ { - cl_fixnum n = fixnnint(count); + cl_fixnum n = fixnnint(count); cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); - if (semaphore->semaphore.queue_list != ECL_NIL) { - ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); - } + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); + if (semaphore->semaphore.queue_list != ECL_NIL) { + ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); + } @(return) } @) @@ -94,36 +94,36 @@ mp_semaphore_wait_count(cl_object semaphore) static cl_object get_semaphore_inner(cl_env_ptr env, cl_object semaphore) { - cl_object output; - ecl_disable_interrupts_env(env); - do { - cl_fixnum counter = semaphore->semaphore.counter; - if (!counter) { - output = ECL_NIL; - break; - } - if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), - (AO_t)counter, (AO_t)(counter-1))) { - output = ecl_make_fixnum(counter); - break; - } - ecl_process_yield(); - } while (1); - ecl_enable_interrupts_env(env); - return output; + cl_object output; + ecl_disable_interrupts_env(env); + do { + cl_fixnum counter = semaphore->semaphore.counter; + if (!counter) { + output = ECL_NIL; + break; + } + if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), + (AO_t)counter, (AO_t)(counter-1))) { + output = ecl_make_fixnum(counter); + break; + } + ecl_process_yield(); + } while (1); + ecl_enable_interrupts_env(env); + return output; } cl_object mp_wait_on_semaphore(cl_object semaphore) { cl_env_ptr env = ecl_process_env(); - cl_object output; - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - output = get_semaphore_inner(env, semaphore); - if (Null(output)) { - output = ecl_wait_on(env, get_semaphore_inner, semaphore); - } - ecl_return1(env, output); + cl_object output; + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + output = get_semaphore_inner(env, semaphore); + if (Null(output)) { + output = ecl_wait_on(env, get_semaphore_inner, semaphore); + } + ecl_return1(env, output); } diff --git a/src/c/time.d b/src/c/time.d index 797fe936d..6db52da00 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -48,25 +48,25 @@ void ecl_get_internal_real_time(struct ecl_timeval *tv) { #if defined(HAVE_GETTIMEOFDAY) && !defined(ECL_MS_WINDOWS_HOST) - struct timezone tz; - struct timeval aux; - gettimeofday(&aux, &tz); - tv->tv_usec = aux.tv_usec; - tv->tv_sec = aux.tv_sec; + struct timezone tz; + struct timeval aux; + gettimeofday(&aux, &tz); + tv->tv_usec = aux.tv_usec; + tv->tv_sec = aux.tv_sec; #else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } system_time; - GetSystemTimeAsFileTime(&system_time.filetime); - system_time.hundred_ns /= 10000; - tv->tv_sec = system_time.hundred_ns / 1000; - tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } system_time; + GetSystemTimeAsFileTime(&system_time.filetime); + system_time.hundred_ns /= 10000; + tv->tv_sec = system_time.hundred_ns / 1000; + tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; # else - time_t = time(0); - tv->tv_sec = time_t; - tv->tv_usec = 0; + time_t = time(0); + tv->tv_sec = time_t; + tv->tv_usec = 0; # endif #endif } @@ -75,34 +75,34 @@ void ecl_get_internal_run_time(struct ecl_timeval *tv) { #ifdef HAVE_GETRUSAGE - struct rusage r; - getrusage(RUSAGE_SELF, &r); - tv->tv_usec = r.ru_utime.tv_usec; - tv->tv_sec = r.ru_utime.tv_sec; + struct rusage r; + getrusage(RUSAGE_SELF, &r); + tv->tv_usec = r.ru_utime.tv_usec; + tv->tv_sec = r.ru_utime.tv_sec; #else # ifdef HAVE_TIMES - struct tms buf; - times(&buf); - tv->tv_sec = buf.tms_utime / CLK_TCK; - tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; + struct tms buf; + times(&buf); + tv->tv_sec = buf.tms_utime / CLK_TCK; + tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; # else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } kernel_time, user_time, creation_time, exit_time; - if (!GetProcessTimes(GetCurrentProcess(), - &creation_time.filetime, - &exit_time.filetime, - &kernel_time.filetime, - &user_time.filetime)) - FEwin32_error("GetProcessTimes() failed", 0); - kernel_time.hundred_ns += user_time.hundred_ns; - kernel_time.hundred_ns /= 10000; - tv->tv_sec = kernel_time.hundred_ns / 1000; - tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } kernel_time, user_time, creation_time, exit_time; + if (!GetProcessTimes(GetCurrentProcess(), + &creation_time.filetime, + &exit_time.filetime, + &kernel_time.filetime, + &user_time.filetime)) + FEwin32_error("GetProcessTimes() failed", 0); + kernel_time.hundred_ns += user_time.hundred_ns; + kernel_time.hundred_ns /= 10000; + tv->tv_sec = kernel_time.hundred_ns / 1000; + tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; # else - ecl_get_internal_real_time(tv); + ecl_get_internal_real_time(tv); # endif # endif #endif @@ -112,59 +112,59 @@ void ecl_musleep(double time, bool alertable) { #ifdef HAVE_NANOSLEEP - struct timespec tm; - int code; - tm.tv_sec = (time_t)floor(time); - tm.tv_nsec = (long)((time - floor(time)) * 1e9); + struct timespec tm; + int code; + tm.tv_sec = (time_t)floor(time); + tm.tv_nsec = (long)((time - floor(time)) * 1e9); AGAIN: - code = nanosleep(&tm, &tm); - { - int old_errno = errno; - if (code < 0 && old_errno == EINTR && !alertable) { - goto AGAIN; - } - } + code = nanosleep(&tm, &tm); + { + int old_errno = errno; + if (code < 0 && old_errno == EINTR && !alertable) { + goto AGAIN; + } + } #else #if defined (ECL_MS_WINDOWS_HOST) - /* Maximum waiting time that fits in SleepEx. This is the - * largest integer that fits safely in DWORD in milliseconds - * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ - const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; - DWORDLONG wait = time * 1e7; - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } end, now; - if (alertable) { - GetSystemTimeAsFileTime(&end.filetime); - end.hundred_ns += wait; - } - do { - DWORDLONG interval; - if (wait > maxtime) { - interval = maxtime; - wait -= maxtime; - } else { - interval = wait; - wait = 0; - } - if (SleepEx(interval/10000, alertable) != 0) { - if (alertable) { - break; - } else { - GetSystemTimeAsFileTime(&now.filetime); - if (now.hundred_ns >= end.hundred_ns) - break; - else - wait = end.hundred_ns - now.hundred_ns; - } - } - } while (wait); + /* Maximum waiting time that fits in SleepEx. This is the + * largest integer that fits safely in DWORD in milliseconds + * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ + const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; + DWORDLONG wait = time * 1e7; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } end, now; + if (alertable) { + GetSystemTimeAsFileTime(&end.filetime); + end.hundred_ns += wait; + } + do { + DWORDLONG interval; + if (wait > maxtime) { + interval = maxtime; + wait -= maxtime; + } else { + interval = wait; + wait = 0; + } + if (SleepEx(interval/10000, alertable) != 0) { + if (alertable) { + break; + } else { + GetSystemTimeAsFileTime(&now.filetime); + if (now.hundred_ns >= end.hundred_ns) + break; + else + wait = end.hundred_ns - now.hundred_ns; + } + } + } while (wait); #else - int t = (int)time; - for (t = (time + 0.5); t > 1000; t -= 1000) - sleep(1000); - sleep(t); + int t = (int)time; + for (t = (time + 0.5); t > 1000; t -= 1000) + sleep(1000); + sleep(t); #endif #endif } @@ -172,21 +172,21 @@ ecl_musleep(double time, bool alertable) cl_fixnum ecl_runtime(void) { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return tv.tv_sec * 1000 + tv.tv_usec / 1000; + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return tv.tv_sec * 1000 + tv.tv_usec / 1000; } cl_object cl_sleep(cl_object z) { double time; - /* INV: ecl_minusp() makes sure `z' is real */ - if (ecl_minusp(z)) - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a non-negative number ~S"), - @':format-arguments', cl_list(1, z), - @':expected-type', @'real', @':datum', z); + /* INV: ecl_minusp() makes sure `z' is real */ + if (ecl_minusp(z)) + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a non-negative number ~S"), + @':format-arguments', cl_list(1, z), + @':expected-type', @'real', @':datum', z); /* Compute time without overflows */ ECL_WITHOUT_FPE_BEGIN { time = ecl_to_double(z); @@ -196,51 +196,51 @@ cl_sleep(cl_object z) time = 1e-9; } } ECL_WITHOUT_FPE_END; - ecl_musleep(time, 0); - @(return ECL_NIL) + ecl_musleep(time, 0); + @(return ECL_NIL) } static cl_object timeval_to_time(long sec, long usec) { - cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), - ecl_make_fixnum(1000)), - ecl_make_integer(usec / 1000)); - @(return milliseconds); + cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), + ecl_make_fixnum(1000)), + ecl_make_integer(usec / 1000)); + @(return milliseconds); } cl_object cl_get_internal_run_time() { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return timeval_to_time(tv.tv_sec, tv.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return timeval_to_time(tv.tv_sec, tv.tv_usec); } cl_object cl_get_internal_real_time() { - struct ecl_timeval tv; - ecl_get_internal_real_time(&tv); - return timeval_to_time(tv.tv_sec - beginning.tv_sec, - tv.tv_usec - beginning.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_real_time(&tv); + return timeval_to_time(tv.tv_sec - beginning.tv_sec, + tv.tv_usec - beginning.tv_usec); } cl_object cl_get_universal_time() { - cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)) + cl_object utc = ecl_make_integer(time(0)); + @(return ecl_plus(utc, cl_core.Jan1st1970UT)) } void init_unixtime(void) { - ecl_get_internal_real_time(&beginning); + ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); + ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); + cl_core.Jan1st1970UT = + ecl_times(ecl_make_fixnum(24 * 60 * 60), + ecl_make_fixnum(17 + 365 * 70)); } diff --git a/src/c/typespec.d b/src/c/typespec.d index afa46d22d..24ffa69f3 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -19,83 +19,83 @@ void FEtype_error_fixnum(cl_object x) { - FEwrong_type_argument(@[fixnum], x); + FEwrong_type_argument(@[fixnum], x); } void FEtype_error_size(cl_object x) { - FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), - x); + FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), + x); } void FEtype_error_cons(cl_object x) { - FEwrong_type_argument(@[cons], x); + FEwrong_type_argument(@[cons], x); } void FEtype_error_list(cl_object x) { - FEwrong_type_argument(@[list], x); + FEwrong_type_argument(@[list], x); } void FEtype_error_proper_list(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a proper list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', ecl_read_from_cstring("si::proper-list"), - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a proper list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', ecl_read_from_cstring("si::proper-list"), + @':datum', x); } void FEcircular_list(cl_object x) { - /* FIXME: Is this the right way to rebind it? */ - ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Circular list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'list', - @':datum', x); + /* FIXME: Is this the right way to rebind it? */ + ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Circular list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'list', + @':datum', x); } void FEtype_error_index(cl_object seq, cl_fixnum ndx) { cl_object n = ecl_make_fixnum(ndx); - cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S is not a valid index into the object ~S"), - @':format-arguments', cl_list(2, n, seq), - @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), - @':datum', n); + cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S is not a valid index into the object ~S"), + @':format-arguments', cl_list(2, n, seq), + @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), + @':datum', n); } void FEtype_error_array(cl_object v) { - FEwrong_type_argument(@[array], v); + FEwrong_type_argument(@[array], v); } void FEtype_error_vector(cl_object v) { - FEwrong_type_argument(@[vector], v); + FEwrong_type_argument(@[vector], v); } void FEtype_error_sequence(cl_object x) { - FEwrong_type_argument(@[sequence], x); + FEwrong_type_argument(@[sequence], x); } cl_object ecl_type_error(cl_object function, const char *place, cl_object o, - cl_object type) + cl_object type) { - si_wrong_type_argument(4, o, type, - (*place? make_constant_base_string(place) : ECL_NIL), - function); + si_wrong_type_argument(4, o, type, + (*place? make_constant_base_string(place) : ECL_NIL), + function); } /**********************************************************************/ @@ -103,256 +103,256 @@ ecl_type_error(cl_object function, const char *place, cl_object o, static cl_object ecl_type_to_symbol(cl_type t) { - switch(t) { - case t_character: - return @'character'; - case t_fixnum: - return @'fixnum'; - case t_bignum: - return @'bignum'; - case t_ratio: - return @'ratio'; - case t_singlefloat: - return @'single-float'; - case t_doublefloat: - return @'double-float'; + switch(t) { + case t_character: + return @'character'; + case t_fixnum: + return @'fixnum'; + case t_bignum: + return @'bignum'; + case t_ratio: + return @'ratio'; + case t_singlefloat: + return @'single-float'; + case t_doublefloat: + return @'double-float'; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return @'long-float'; + case t_longfloat: + return @'long-float'; #endif - case t_complex: - return @'complex'; - case t_symbol: - return @'symbol'; - case t_package: - return @'package'; - case t_list: - return @'list'; - case t_hashtable: - return @'hash-table'; - case t_array: - return @'array'; - case t_vector: - return @'vector'; - case t_bitvector: - return @'bit-vector'; + case t_complex: + return @'complex'; + case t_symbol: + return @'symbol'; + case t_package: + return @'package'; + case t_list: + return @'list'; + case t_hashtable: + return @'hash-table'; + case t_array: + return @'array'; + case t_vector: + return @'vector'; + case t_bitvector: + return @'bit-vector'; #ifdef ECL_UNICODE - case t_string: - return @'string'; + case t_string: + return @'string'; #endif - case t_base_string: - return @'base-string'; - case t_stream: - return @'stream'; - case t_readtable: - return @'readtable'; - case t_pathname: - return @'pathname'; - case t_random: - return @'random-state'; - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - return @'compiled-function'; + case t_base_string: + return @'base-string'; + case t_stream: + return @'stream'; + case t_readtable: + return @'readtable'; + case t_pathname: + return @'pathname'; + case t_random: + return @'random-state'; + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + return @'compiled-function'; #ifdef ECL_THREADS - case t_process: - return @'mp::process'; - case t_lock: - return @'mp::lock'; - case t_condition_variable: - return @'mp::condition-variable'; - case t_semaphore: - return @'mp::semaphore'; - case t_barrier: - return @'mp::barrier'; - case t_mailbox: - return @'mp::mailbox'; + case t_process: + return @'mp::process'; + case t_lock: + return @'mp::lock'; + case t_condition_variable: + return @'mp::condition-variable'; + case t_semaphore: + return @'mp::semaphore'; + case t_barrier: + return @'mp::barrier'; + case t_mailbox: + return @'mp::mailbox'; #endif - case t_codeblock: - return @'si::code-block'; - case t_foreign: - return @'si::foreign-data'; - case t_frame: - return @'si::frame'; - case t_weak_pointer: - return @'ext::weak-pointer'; + case t_codeblock: + return @'si::code-block'; + case t_foreign: + return @'si::foreign-data'; + case t_frame: + return @'si::frame'; + case t_weak_pointer: + return @'ext::weak-pointer'; #ifdef ECL_SSE2 - case t_sse_pack: - return @'ext::sse-pack'; + case t_sse_pack: + return @'ext::sse-pack'; #endif - default: - ecl_internal_error("not a lisp data object"); - } + default: + ecl_internal_error("not a lisp data object"); + } } cl_object ecl_check_cl_type(cl_object fun, cl_object p, cl_type t) { - while (ecl_t_of(p) != t) { - p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); - } - return p; + while (ecl_t_of(p) != t) { + p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); + } + return p; } void assert_type_integer(cl_object p) { - cl_type t = ecl_t_of(p); - if (t != t_fixnum && t != t_bignum) + cl_type t = ecl_t_of(p); + if (t != t_fixnum && t != t_bignum) FEwrong_type_nth_arg(@[coerce], 1, p, @[integer]); } void assert_type_non_negative_integer(cl_object p) { - cl_type t = ecl_t_of(p); + cl_type t = ecl_t_of(p); - if (t == t_fixnum) { - if (ecl_fixnum_plusp(p)) - return; - } else if (t == t_bignum) { - if (_ecl_big_sign(p) >= 0) - return; - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); + if (t == t_fixnum) { + if (ecl_fixnum_plusp(p)) + return; + } else if (t == t_bignum) { + if (_ecl_big_sign(p) >= 0) + return; + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); } void assert_type_proper_list(cl_object p) { - if (ECL_ATOM(p) && p != ECL_NIL) - FEtype_error_list(p); - if (cl_list_length(p) == ECL_NIL) - FEcircular_list(p); + if (ECL_ATOM(p) && p != ECL_NIL) + FEtype_error_list(p); + if (cl_list_length(p) == ECL_NIL) + FEcircular_list(p); } cl_object cl_type_of(cl_object x) { - cl_object t; - cl_type tx = ecl_t_of(x); - switch (tx) { + cl_object t; + cl_type tx = ecl_t_of(x); + switch (tx) { #ifdef CLOS case t_instance: { - cl_object cl = ECL_CLASS_OF(x); - t = ECL_CLASS_NAME(cl); - if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) - t = cl; - break; - } + cl_object cl = ECL_CLASS_OF(x); + t = ECL_CLASS_NAME(cl); + if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) + t = cl; + break; + } #endif #if 1 - case t_fixnum: - case t_bignum: - t = cl_list(3, @'integer', x, x); break; + case t_fixnum: + case t_bignum: + t = cl_list(3, @'integer', x, x); break; #endif - case t_character: { - int i = ECL_CHAR_CODE(x); - if (ecl_standard_char_p(i)) { - t = @'standard-char'; - } else if (ecl_base_char_p(i)) { - t = @'base-char'; - } else { - t = @'character'; - } - break; - } + case t_character: { + int i = ECL_CHAR_CODE(x); + if (ecl_standard_char_p(i)) { + t = @'standard-char'; + } else if (ecl_base_char_p(i)) { + t = @'base-char'; + } else { + t = @'character'; + } + break; + } - case t_symbol: - if (x == ECL_T) - t = @'boolean'; - else if (x->symbol.hpack == cl_core.keyword_package) - t = @'keyword'; - else - t = @'symbol'; - break; - case t_array: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->array.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), + case t_symbol: + if (x == ECL_T) + t = @'boolean'; + else if (x->symbol.hpack == cl_core.keyword_package) + t = @'keyword'; + else + t = @'symbol'; + break; + case t_array: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->array.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), cl_array_dimensions(x)); - break; - case t_vector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->vector.displaced))) { - t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), - ecl_make_fixnum(x->vector.dim)); - } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || - (cl_elttype)x->vector.elttype != ecl_aet_object) { - t = cl_list(3, @'simple-array', + break; + case t_vector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->vector.displaced))) { + t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), + ecl_make_fixnum(x->vector.dim)); + } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || + (cl_elttype)x->vector.elttype != ecl_aet_object) { + t = cl_list(3, @'simple-array', ecl_elttype_to_symbol(ecl_array_elttype(x)), - cl_array_dimensions(x)); - } else { - t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); - } - break; + cl_array_dimensions(x)); + } else { + t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); + } + break; #ifdef ECL_UNICODE - case t_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); - break; + case t_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); + break; #endif - case t_base_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->base_string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); - break; - case t_bitvector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->vector.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); - break; + case t_base_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->base_string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); + break; + case t_bitvector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->vector.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); + break; #ifndef CLOS - case t_structure: - t = x->str.name; break; + case t_structure: + t = x->str.name; break; #endif - case t_stream: - switch (x->stream.mode) { - case ecl_smm_synonym: t = @'synonym-stream'; break; - case ecl_smm_broadcast: t = @'broadcast-stream'; break; - case ecl_smm_concatenated: t = @'concatenated-stream'; break; - case ecl_smm_two_way: t = @'two-way-stream'; break; - case ecl_smm_string_input: - case ecl_smm_string_output: t = @'string-stream'; break; - case ecl_smm_echo: t = @'echo-stream'; break; + case t_stream: + switch (x->stream.mode) { + case ecl_smm_synonym: t = @'synonym-stream'; break; + case ecl_smm_broadcast: t = @'broadcast-stream'; break; + case ecl_smm_concatenated: t = @'concatenated-stream'; break; + case ecl_smm_two_way: t = @'two-way-stream'; break; + case ecl_smm_string_input: + case ecl_smm_string_output: t = @'string-stream'; break; + case ecl_smm_echo: t = @'echo-stream'; break; case ecl_smm_sequence_input: case ecl_smm_sequence_output: t = @'ext::sequence-stream'; break; - default: t = @'file-stream'; break; - } - break; - case t_pathname: - t = x->pathname.logical? @'logical-pathname' : @'pathname'; - break; - case t_list: - t = Null(x) ? @'null' : @'cons'; - break; + default: t = @'file-stream'; break; + } + break; + case t_pathname: + t = x->pathname.logical? @'logical-pathname' : @'pathname'; + break; + case t_list: + t = Null(x) ? @'null' : @'cons'; + break; #ifdef ECL_SSE2 - case t_sse_pack: - t = @'ext::sse-pack'; - break; + case t_sse_pack: + t = @'ext::sse-pack'; + break; #endif - default: - t = ecl_type_to_symbol(tx); - } - @(return t) + default: + t = ecl_type_to_symbol(tx); + } + @(return t) } cl_object diff --git a/src/c/unicode/ucd_names_char.c b/src/c/unicode/ucd_names_char.c index 93f83c670..19d40afe0 100644 --- a/src/c/unicode/ucd_names_char.c +++ b/src/c/unicode/ucd_names_char.c @@ -555,7 +555,7 @@ _ecl_ucd_name_to_code(cl_object name) ecl_character c = ecl_char_upcase(ecl_char(name, mid)); buffer1[mid] = c; if (c < 32 || c > 127) /* All character names are [-A-Z_0-9]* */ - return ECL_NIL; + return ECL_NIL; } buffer1[mid] = 0; do { diff --git a/src/c/unify.d b/src/c/unify.d index de9a5cb82..16bfcd14d 100644 --- a/src/c/unify.d +++ b/src/c/unify.d @@ -18,15 +18,15 @@ #include "ecl.h" #include "unify.h" -object *slot; /* scanning pointer within object */ -int (*slotf)(); /* read/write mode accessor */ +object *slot; /* scanning pointer within object */ +int (*slotf)(); /* read/write mode accessor */ /* -------------------- Trail Instructions -------------------- */ object *trail[VSSIZE]; object **trail_top = trail; -#define BIND(loc, val) {loc = val; trail_push(&loc);} +#define BIND(loc, val) {loc = val; trail_push(&loc);} @(defun trail_mark () @ @@ -47,18 +47,18 @@ object **trail_top = trail; /* -------------------- Mode Operators -------------------- */ -bool get_slot(object x) /* read mode */ +bool get_slot(object x) /* read mode */ { if (x == *slot || unify(x, *slot)) if (*slot == OBJNULL) return((bool)MAKE_LOCATIVE(slot++)); else - return((bool)*slot++); /* dereference */ + return((bool)*slot++); /* dereference */ else return(FALSE); } -bool set_slot(object x) /* write mode */ +bool set_slot(object x) /* write mode */ { /* NOTE: slot contains OBJNULL */ *slot = x; @@ -72,96 +72,96 @@ bool set_slot(object x) /* write mode */ @(defun get_value (v x) @ - @(return (get_value(v, x)?ECL_T:ECL_NIL)) + @(return (get_value(v, x)?ECL_T:ECL_NIL)) @) @(defun get_constant (c x) @ - @(return (get_constant(c, x)?ECL_T:ECL_NIL)) + @(return (get_constant(c, x)?ECL_T:ECL_NIL)) @) @(defun get_nil (arg) @ - @(return (get_nil(arg)?ECL_T:ECL_NIL)) + @(return (get_nil(arg)?ECL_T:ECL_NIL)) @) bool get_cons(object x) { -RETRY: switch (ecl_t_of(x)) { - case t_cons: - slot = &CDR(x); /* cdr slot is first in struct cons */ - slotf = get_slot; - return(TRUE); +RETRY: switch (ecl_t_of(x)) { + case t_cons: + slot = &CDR(x); /* cdr slot is first in struct cons */ + slotf = get_slot; + return(TRUE); - case t_locative: - if (UNBOUNDP(x)) { - object new = CONS(OBJNULL, OBJNULL); - BIND(DEREF(x), new); - slot = &CDR(new); - slotf = set_slot; - return(TRUE); - } - else { - x = DEREF(x); - goto RETRY; - } + case t_locative: + if (UNBOUNDP(x)) { + object new = CONS(OBJNULL, OBJNULL); + BIND(DEREF(x), new); + slot = &CDR(new); + slotf = set_slot; + return(TRUE); + } + else { + x = DEREF(x); + goto RETRY; + } - default: return(FALSE); - } - + default: return(FALSE); + } + } @(defun get_cons (arg) @ - @(return (get_cons(arg)?ECL_T:ECL_NIL)) + @(return (get_cons(arg)?ECL_T:ECL_NIL)) @) bool get_instance(object x, object class, int arity) { -RETRY: switch (ecl_t_of(x)) { - case t_instance: - if (ECL_CLASS_OF(x) == class) { - slot = x->instance.slots; - slotf = get_slot; - return(TRUE); - } else - return(FALSE); +RETRY: switch (ecl_t_of(x)) { + case t_instance: + if (ECL_CLASS_OF(x) == class) { + slot = x->instance.slots; + slotf = get_slot; + return(TRUE); + } else + return(FALSE); - case t_locative: - if (UNBOUNDP(x)) { - object new = allocate_instance(class, arity); - BIND(DEREF(x), new); - slot = new->instance.slots; - slotf = set_slot; - return(TRUE); - } - else { - x = DEREF(x); - goto RETRY; - } - default: return(FALSE); - } + case t_locative: + if (UNBOUNDP(x)) { + object new = allocate_instance(class, arity); + BIND(DEREF(x), new); + slot = new->instance.slots; + slotf = set_slot; + return(TRUE); + } + else { + x = DEREF(x); + goto RETRY; + } + default: return(FALSE); + } } @(defun get_instance (x class arity) @ - @(return (get_instance(x, class, ecl_fixnum(arity))?ECL_T:ECL_NIL)) + @(return (get_instance(x, class, ecl_fixnum(arity))?ECL_T:ECL_NIL)) @) /* -------------------- Unify Instructions -------------------- */ -#define UNIFY_LOCATIVE(x, y, L) {object *p = &DEREF(x); \ - if (*p == OBJNULL) { \ - BIND(*p, y); return(TRUE); } \ - else { x = *p; goto L;}} +#define UNIFY_LOCATIVE(x, y, L) {object *p = &DEREF(x); \ + if (*p == OBJNULL) { \ + BIND(*p, y); return(TRUE); } \ + else { x = *p; goto L;}} /* #define UNIFY_LOCATIVE(x, y, L) {if (UNBOUNDP(x)) { \ - BIND(DEREF(x), y); return(TRUE); } \ - else { x = DEREF(x); goto L;}} + BIND(DEREF(x), y); return(TRUE); } \ + else { x = DEREF(x); goto L;}} */ bool @@ -177,7 +177,7 @@ unify(object x, object y) L1: switch (ecl_t_of(y)) { case t_cons: return(unify(CAR(x), CAR(y)) && - unify(CDR(x), CDR(y))); + unify(CDR(x), CDR(y))); case t_locative: UNIFY_LOCATIVE(y, x, L1); @@ -188,17 +188,17 @@ unify(object x, object y) L2: switch (ecl_t_of(y)) { case t_instance: - if (ECL_CLASS_OF(x) == ECL_CLASS_OF(y)) { - int l = x->instance.length; int i; - object *slotx = x->instance.slots; - object *sloty = y->instance.slots; - for (i = 0; i < l; i++) { - if (!unify(*slotx++, *sloty++)) - return(FALSE); - } - return(TRUE); - } else - return(FALSE); + if (ECL_CLASS_OF(x) == ECL_CLASS_OF(y)) { + int l = x->instance.length; int i; + object *slotx = x->instance.slots; + object *sloty = y->instance.slots; + for (i = 0; i < l; i++) { + if (!unify(*slotx++, *sloty++)) + return(FALSE); + } + return(TRUE); + } else + return(FALSE); case t_locative: UNIFY_LOCATIVE(y, x, L2); @@ -209,9 +209,9 @@ unify(object x, object y) L3: if (LOCATIVEP(y)) UNIFY_LOCATIVE(y, x, L3) else if (equal(x,y)) - return(TRUE); - else - return(FALSE); + return(TRUE); + else + return(FALSE); } } @@ -219,59 +219,59 @@ unify(object x, object y) @(defun unify_slot () @ - @(return ((object)unify_slot)) + @(return ((object)unify_slot)) @) @(defun unify_value (loc) object x; @ - x = (object)unify_value(loc); - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) + x = (object)unify_value(loc); + @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) @) @(defun unify_constant (c) object x; @ - x = (object)unify_constant(c); - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) + x = (object)unify_constant(c); + @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) @) @(defun unify_nil () object x; @ - x = (object)unify_nil; - @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) + x = (object)unify_nil; + @(return ((x == ECL_NIL || x)?ECL_T:ECL_NIL)) @) /* -------------------- Test Functions -------------------- */ @(defun make_locative (&optional (n 0)) @ - @(return (MAKE_LOCATIVE(ecl_fixnum(n)))) + @(return (MAKE_LOCATIVE(ecl_fixnum(n)))) @) @(defun locativep (obje) @ - @(return (LOCATIVEP(obje)?ECL_T:ECL_NIL)) + @(return (LOCATIVEP(obje)?ECL_T:ECL_NIL)) @) @(defun unboundp (loc) @ - @(return (UNBOUNDP(loc)?ECL_T:ECL_NIL)) + @(return (UNBOUNDP(loc)?ECL_T:ECL_NIL)) @) @(defun dereference (x) extern object Slocative; @ - while (ecl_t_of(x) != t_locative) - x = wrong_type_argument(Slocative, x); - @(return (DEREF(x))) + while (ecl_t_of(x) != t_locative) + x = wrong_type_argument(Slocative, x); + @(return (DEREF(x))) @) @(defun make_variable (name) @ - @(return (CONS(name, OBJNULL))) + @(return (CONS(name, OBJNULL))) @) /* (defmacro unify-variable (v) `(progn (setq ,v (si:unify-slot)) t) */ @@ -280,20 +280,20 @@ object Ssetq, Sunify_slot; @(defun unify_variable (object var) @ - @(return list(3, Sprogn, - list(3, Ssetq, CADR(var), - CONS(Sunify_slot, ECL_NIL)), - ECL_T)) + @(return list(3, Sprogn, + list(3, Ssetq, CADR(var), + CONS(Sunify_slot, ECL_NIL)), + ECL_T)) @) -#define make_si_macro(name, cfun) \ - {object x = make_si_ordinary(name); \ - ECL_SYM_FUN(x) = make_cfun(cfun, ECL_NIL, NULL); \ - x->symbol.mflag = TRUE; \ - } +#define make_si_macro(name, cfun) \ + {object x = make_si_ordinary(name); \ + ECL_SYM_FUN(x) = make_cfun(cfun, ECL_NIL, NULL); \ + x->symbol.mflag = TRUE; \ + } void init_unify(void) { - make_si_macro("UNIFY-VARIABLE", Lunify_variable); + make_si_macro("UNIFY-VARIABLE", Lunify_variable); } diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index f5ee87ce6..473891beb 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -57,49 +57,49 @@ ecl_def_ct_base_string(str_slash,"/",1,static,const); static cl_object coerce_to_posix_filename(cl_object filename) { - /* This converts a pathname designator into a namestring, with the - * particularity that directories do not end with a slash '/', because - * this is not supported on all POSIX platforms (most notably Windows) - */ - filename = si_coerce_to_filename(filename); - return cl_string_right_trim(str_slash, filename); + /* This converts a pathname designator into a namestring, with the + * particularity that directories do not end with a slash '/', because + * this is not supported on all POSIX platforms (most notably Windows) + */ + filename = si_coerce_to_filename(filename); + return cl_string_right_trim(str_slash, filename); } static int safe_chdir(const char *path, cl_object prefix) { - if (prefix != ECL_NIL) { - cl_object aux = make_constant_base_string(path); - aux = si_base_string_concatenate(2, prefix, aux); - return safe_chdir((char *)aux->base_string.self, ECL_NIL); - } else { - int output; - ecl_disable_interrupts(); - output = chdir((char *)path); - ecl_enable_interrupts(); - return output; - } + if (prefix != ECL_NIL) { + cl_object aux = make_constant_base_string(path); + aux = si_base_string_concatenate(2, prefix, aux); + return safe_chdir((char *)aux->base_string.self, ECL_NIL); + } else { + int output; + ecl_disable_interrupts(); + output = chdir((char *)path); + ecl_enable_interrupts(); + return output; + } } static int safe_stat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = stat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = stat(path, sb); + ecl_enable_interrupts(); + return output; } #ifdef HAVE_LSTAT static int safe_lstat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = lstat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = lstat(path, sb); + ecl_enable_interrupts(); + return output; } #endif @@ -107,23 +107,23 @@ safe_lstat(const char *path, struct stat *sb) static cl_object drive_host_prefix(cl_object pathname) { - cl_object device = pathname->pathname.device; - cl_object host = pathname->pathname.host; - cl_object output = ECL_NIL; - if (device != ECL_NIL) { - output = make_base_string_copy("X:"); - output->base_string.self[0] = device->base_string.self[0]; - } - if (host != ECL_NIL) { - cl_object slash = cl_core.slash; - if (output != ECL_NIL) - output = si_base_string_concatenate(5, output, slash, slash, - host, slash); - else - output = si_base_string_concatenate(4, slash, slash, host, - slash); - } - return output; + cl_object device = pathname->pathname.device; + cl_object host = pathname->pathname.host; + cl_object output = ECL_NIL; + if (device != ECL_NIL) { + output = make_base_string_copy("X:"); + output->base_string.self[0] = device->base_string.self[0]; + } + if (host != ECL_NIL) { + cl_object slash = cl_core.slash; + if (output != ECL_NIL) + output = si_base_string_concatenate(5, output, slash, slash, + host, slash); + else + output = si_base_string_concatenate(4, slash, slash, host, + slash); + } + return output; } #else #define drive_host_prefix(x) ECL_NIL @@ -135,8 +135,8 @@ drive_host_prefix(cl_object pathname) cl_object ecl_cstring_to_pathname(char *s) { - cl_object string = ecl_make_simple_base_string(s, -1); - return cl_parse_namestring(1, string); + cl_object string = ecl_make_simple_base_string(s, -1); + return cl_parse_namestring(1, string); } /* @@ -145,38 +145,38 @@ ecl_cstring_to_pathname(char *s) */ static cl_object current_dir(void) { - cl_object output; - const char *ok; + cl_object output; + const char *ok; #ifdef _MSC_VER - unsigned char *c; + unsigned char *c; #endif - cl_index size = 128; + cl_index size = 128; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - ok = getcwd((char*)output->base_string.self, size); - ecl_enable_interrupts(); - size += 256; - } while (ok == NULL); - size = strlen((char*)output->base_string.self); - if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { - /* Too large to host the trailing '/' */ - cl_object other = ecl_alloc_adjustable_base_string(size+2); - strcpy((char*)other->base_string.self, (char*)output->base_string.self); - output = other; - } + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + ok = getcwd((char*)output->base_string.self, size); + ecl_enable_interrupts(); + size += 256; + } while (ok == NULL); + size = strlen((char*)output->base_string.self); + if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { + /* Too large to host the trailing '/' */ + cl_object other = ecl_alloc_adjustable_base_string(size+2); + strcpy((char*)other->base_string.self, (char*)output->base_string.self); + output = other; + } #ifdef _MSC_VER - for (c = output->base_string.self; *c; c++) - if (*c == '\\') - *c = '/'; + for (c = output->base_string.self; *c; c++) + if (*c == '\\') + *c = '/'; #endif - if (output->base_string.self[size-1] != '/') { - output->base_string.self[size++] = '/'; - output->base_string.self[size] = 0; - } - output->base_string.fillp = size; - return output; + if (output->base_string.self[size-1] != '/') { + output->base_string.self[size++] = '/'; + output->base_string.self[size] = 0; + } + output->base_string.fillp = size; + return output; } /* @@ -185,69 +185,69 @@ current_dir(void) { static cl_object file_kind(char *filename, bool follow_links) { - cl_object output; + cl_object output; #if defined(ECL_MS_WINDOWS_HOST) - DWORD dw; - ecl_disable_interrupts(); - dw = GetFileAttributes( filename ); - if (dw == -1) - output = ECL_NIL; - else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) - output = @':directory'; - else - output = @':file'; - ecl_enable_interrupts(); + DWORD dw; + ecl_disable_interrupts(); + dw = GetFileAttributes( filename ); + if (dw == -1) + output = ECL_NIL; + else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) + output = @':directory'; + else + output = @':file'; + ecl_enable_interrupts(); #else - struct stat buf; + struct stat buf; # ifdef HAVE_LSTAT - if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) + if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) # else - if (safe_stat(filename, &buf) < 0) + if (safe_stat(filename, &buf) < 0) # endif - output = ECL_NIL; + output = ECL_NIL; # ifdef HAVE_LSTAT - else if (S_ISLNK(buf.st_mode)) - output = @':link'; + else if (S_ISLNK(buf.st_mode)) + output = @':link'; # endif - else if (S_ISDIR(buf.st_mode)) - output = @':directory'; - else if (S_ISREG(buf.st_mode)) - output = @':file'; - else - output = @':special'; + else if (S_ISDIR(buf.st_mode)) + output = @':directory'; + else if (S_ISREG(buf.st_mode)) + output = @':file'; + else + output = @':special'; #endif - return output; + return output; } cl_object si_file_kind(cl_object filename, cl_object follow_links) { - filename = coerce_to_posix_filename(filename); - @(return file_kind((char*)filename->base_string.self, !Null(follow_links))) + filename = coerce_to_posix_filename(filename); + @(return file_kind((char*)filename->base_string.self, !Null(follow_links))) } #if defined(HAVE_LSTAT) && !defined(ECL_MS_WINDOWS_HOST) static cl_object si_readlink(cl_object filename) { - /* Given a filename which is a symlink, this routine returns - * the value of this link in the form of a pathname. */ - cl_index size = 128, written; - cl_object output, kind; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - written = readlink((char*)filename->base_string.self, - (char*)output->base_string.self, size); - ecl_enable_interrupts(); - size += 256; - } while (written == size); - output->base_string.self[written] = '\0'; - kind = file_kind((char*)output->base_string.self, FALSE); - if (kind == @':directory') { - output->base_string.self[written++] = '/'; - output->base_string.self[written] = '\0'; - } - output->base_string.fillp = written; - return output; + /* Given a filename which is a symlink, this routine returns + * the value of this link in the form of a pathname. */ + cl_index size = 128, written; + cl_object output, kind; + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + written = readlink((char*)filename->base_string.self, + (char*)output->base_string.self, size); + ecl_enable_interrupts(); + size += 256; + } while (written == size); + output->base_string.self[written] = '\0'; + kind = file_kind((char*)output->base_string.self, FALSE); + if (kind == @':directory') { + output->base_string.self[written++] = '/'; + output->base_string.self[written] = '\0'; + } + output->base_string.fillp = written; + return output; } #endif /* HAVE_LSTAT */ @@ -282,13 +282,13 @@ enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) aux = ecl_append(base_dir->pathname.directory, ecl_list1(aux)); output = cl_make_pathname(4, @':directory', aux, @':defaults', base_dir); aux = ecl_namestring(output, ECL_NAMESTRING_FORCE_BASE_STRING); - /* We remove the trailing '/' from the namestring because the - * POSIX library does not like it. */ + /* We remove the trailing '/' from the namestring because the + * POSIX library does not like it. */ aux->base_string.self[--aux->base_string.fillp] = 0; kind = file_kind((char*)aux->base_string.self, FALSE); if (kind == ECL_NIL) { - if (ignore_if_failure) return ECL_NIL; - FEcannot_open(output); + if (ignore_if_failure) return ECL_NIL; + FEcannot_open(output); #ifdef HAVE_LSTAT } else if (kind == @':link') { output = cl_truename(ecl_merge_pathnames(si_readlink(aux), @@ -300,7 +300,7 @@ enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) #endif } else if (kind != @':directory') { WRONG_DIR: - if (ignore_if_failure) return ECL_NIL; + if (ignore_if_failure) return ECL_NIL; FEerror("The directory~& ~S~&in pathname~& ~S~&" "actually points to a file or special device.", 2, subdir, base_dir); @@ -309,8 +309,8 @@ enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) cl_object newdir= output->pathname.directory; newdir = ecl_nbutlast(newdir, 2); if (Null(newdir)) { - if (ignore_if_failure) return ECL_NIL; - FEerror("Pathname contained an :UP component " + if (ignore_if_failure) return ECL_NIL; + FEerror("Pathname contained an :UP component " "that goes above the base directory:" "~& ~S", 1, output); } @@ -322,8 +322,8 @@ enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) static cl_object make_absolute_pathname(cl_object orig_pathname) { - cl_object base_dir = si_getcwd(0); - cl_object pathname = coerce_to_file_pathname(orig_pathname); + cl_object base_dir = si_getcwd(0); + cl_object pathname = coerce_to_file_pathname(orig_pathname); return ecl_merge_pathnames(pathname, base_dir, @':default'); } @@ -331,9 +331,9 @@ static cl_object make_base_pathname(cl_object pathname) { return ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - ecl_list1(@':absolute'), - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + pathname->pathname.device, + ecl_list1(@':absolute'), + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); } #define FOLLOW_SYMLINKS 1 @@ -341,19 +341,19 @@ make_base_pathname(cl_object pathname) static cl_object file_truename(cl_object pathname, cl_object filename, int flags) { - cl_object kind; - if (Null(pathname)) { - if (Null(filename)) { - ecl_internal_error("file_truename:" + cl_object kind; + if (Null(pathname)) { + if (Null(filename)) { + ecl_internal_error("file_truename:" " both FILENAME and PATHNAME are null!"); - } - pathname = cl_pathname(filename); - } else if (Null(filename)) { - filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); - if (Null(filename)) { - FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); - } - } + } + pathname = cl_pathname(filename); + } else if (Null(filename)) { + filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); + if (Null(filename)) { + FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); + } + } kind = file_kind((char*)filename->base_string.self, FALSE); if (kind == ECL_NIL) { FEcannot_open(filename); @@ -362,10 +362,10 @@ file_truename(cl_object pathname, cl_object filename, int flags) /* The link might be a relative pathname. In that case we have * to merge with the original pathname */ filename = si_readlink(filename); - pathname = ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - pathname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + pathname = ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + pathname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); pathname = ecl_merge_pathnames(filename, pathname, @':default'); return cl_truename(pathname); #endif @@ -394,7 +394,7 @@ file_truename(cl_object pathname, cl_object filename, int flags) } else { pathname->pathname.version = @':newest'; } - @(return pathname kind) + @(return pathname kind) } /* @@ -405,176 +405,176 @@ file_truename(cl_object pathname, cl_object filename, int flags) cl_object cl_truename(cl_object orig_pathname) { - cl_object pathname = make_absolute_pathname(orig_pathname); - cl_object base_dir = make_base_pathname(pathname); + cl_object pathname = make_absolute_pathname(orig_pathname); + cl_object base_dir = make_base_pathname(pathname); cl_object dir; - /* We process the directory part of the filename, removing all - * possible symlinks. To do so, we inspect recursively the - * directory which contains our file, and come back. We also have to - * ensure that the filename itself does not point to a symlink: if so, - * then we resolve the value of the symlink and continue traversing - * the filesystem. - */ + /* We process the directory part of the filename, removing all + * possible symlinks. To do so, we inspect recursively the + * directory which contains our file, and come back. We also have to + * ensure that the filename itself does not point to a symlink: if so, + * then we resolve the value of the symlink and continue traversing + * the filesystem. + */ for (dir = pathname->pathname.directory; !Null(dir); dir = ECL_CONS_CDR(dir)) - { + { base_dir = enter_directory(base_dir, ECL_CONS_CAR(dir), 0); } pathname = ecl_merge_pathnames(base_dir, pathname, @':default'); - @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)) + @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)) } int ecl_backup_open(const char *filename, int option, int mode) { - char *backupfilename = ecl_alloc(strlen(filename) + 5); - if (backupfilename == NULL) { - FElibc_error("Cannot allocate memory for backup filename", 0); - } + char *backupfilename = ecl_alloc(strlen(filename) + 5); + if (backupfilename == NULL) { + FElibc_error("Cannot allocate memory for backup filename", 0); + } - strcat(strcpy(backupfilename, filename), ".BAK"); - ecl_disable_interrupts(); + strcat(strcpy(backupfilename, filename), ".BAK"); + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - /* Windows' rename doesn't replace an existing file */ - if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot remove the file ~S", 1, + /* Windows' rename doesn't replace an existing file */ + if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot remove the file ~S", 1, ecl_make_constant_base_string(backupfilename,-1)); - } + } #endif - if (rename(filename, backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot rename the file ~S to ~S.", 2, - ecl_make_constant_base_string(filename,-1), + if (rename(filename, backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot rename the file ~S to ~S.", 2, + ecl_make_constant_base_string(filename,-1), ecl_make_constant_base_string(backupfilename,-1)); - } - ecl_enable_interrupts(); - ecl_dealloc(backupfilename); - return open(filename, option, mode); + } + ecl_enable_interrupts(); + ecl_dealloc(backupfilename); + return open(filename, option, mode); } cl_object ecl_file_len(int f) { - struct stat filestatus; - memset(&filestatus, 0, sizeof(filestatus)); - ecl_disable_interrupts(); - fstat(f, &filestatus); - ecl_enable_interrupts(); - return ecl_make_integer(filestatus.st_size); + struct stat filestatus; + memset(&filestatus, 0, sizeof(filestatus)); + ecl_disable_interrupts(); + fstat(f, &filestatus); + ecl_enable_interrupts(); + return ecl_make_integer(filestatus.st_size); } @(defun rename-file (oldn newn &key (if_exists @':error')) - cl_object old_filename, new_filename, old_truename, new_truename; - int error; + cl_object old_filename, new_filename, old_truename, new_truename; + int error; @ - /* 1) Get the old filename, and complain if it has wild components, - * or if it does not exist. Notice that the filename to be renamed - * is not the truename, because we might be renaming a symbolic link. - */ - old_truename = cl_truename(oldn); - old_filename = coerce_to_posix_filename(old_truename); + /* 1) Get the old filename, and complain if it has wild components, + * or if it does not exist. Notice that the filename to be renamed + * is not the truename, because we might be renaming a symbolic link. + */ + old_truename = cl_truename(oldn); + old_filename = coerce_to_posix_filename(old_truename); - /* 2) Create the new file name. */ - newn = ecl_merge_pathnames(newn, oldn, @':newest'); - new_filename = si_coerce_to_filename(newn); + /* 2) Create the new file name. */ + newn = ecl_merge_pathnames(newn, oldn, @':newest'); + new_filename = si_coerce_to_filename(newn); - while (if_exists == @':error' || if_exists == ECL_NIL) + while (if_exists == @':error' || if_exists == ECL_NIL) { if (cl_probe_file(new_filename) == ECL_NIL) { if_exists = ECL_T; break; } - /* if the file already exists */ - if (if_exists == @':error') { - const char *msg = "When trying to rename ~S, ~S already exists"; - if_exists = - si_signal_simple_error - (6, @'file-error', /* condition */ - @':supersede', /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, oldn, new_filename), /* format args */ - @':pathname', /* file-error options */ - new_filename); - if (if_exists == ECL_T) if_exists= @':error'; - } - if (if_exists == ECL_NIL) { - @(return ECL_NIL ECL_NIL ECL_NIL) - } - } - if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { - /* invalid key */ - FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", + /* if the file already exists */ + if (if_exists == @':error') { + const char *msg = "When trying to rename ~S, ~S already exists"; + if_exists = + si_signal_simple_error + (6, @'file-error', /* condition */ + @':supersede', /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, oldn, new_filename), /* format args */ + @':pathname', /* file-error options */ + new_filename); + if (if_exists == ECL_T) if_exists= @':error'; + } + if (if_exists == ECL_NIL) { + @(return ECL_NIL ECL_NIL ECL_NIL) + } + } + if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { + /* invalid key */ + FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", 1, if_exists); - } + } { ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - error = SetErrorMode(0); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - switch (GetLastError()) { - case ERROR_ALREADY_EXISTS: - case ERROR_FILE_EXISTS: - break; - default: - goto FAILURE_CLOBBER; - }; - if (MoveFileEx((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self, - MOVEFILE_REPLACE_EXISTING)) { - SetErrorMode(error); - goto SUCCESS; - } - /* hack for win95/novell */ - chmod((char*)old_filename->base_string.self, 0777); - chmod((char*)new_filename->base_string.self, 0777); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_NORMAL); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_TEMPORARY); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fallback on old behavior */ - (void)DeleteFileA((char*)new_filename->base_string.self); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fall through */ + error = SetErrorMode(0); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + switch (GetLastError()) { + case ERROR_ALREADY_EXISTS: + case ERROR_FILE_EXISTS: + break; + default: + goto FAILURE_CLOBBER; + }; + if (MoveFileEx((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self, + MOVEFILE_REPLACE_EXISTING)) { + SetErrorMode(error); + goto SUCCESS; + } + /* hack for win95/novell */ + chmod((char*)old_filename->base_string.self, 0777); + chmod((char*)new_filename->base_string.self, 0777); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_NORMAL); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_TEMPORARY); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fallback on old behavior */ + (void)DeleteFileA((char*)new_filename->base_string.self); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fall through */ #else - if (rename((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self) == 0) { - goto SUCCESS; - } + if (rename((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self) == 0) { + goto SUCCESS; + } #endif - } + } FAILURE_CLOBBER: - ecl_enable_interrupts(); - { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_NIL, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(3, oldn, newn, c_error), /* format args */ - @':pathname', /* file-error options */ - oldn); - } + ecl_enable_interrupts(); + { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_NIL, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(3, oldn, newn, c_error), /* format args */ + @':pathname', /* file-error options */ + oldn); + } SUCCESS: - ecl_enable_interrupts(); - new_truename = cl_truename(newn); - @(return newn old_truename new_truename) + ecl_enable_interrupts(); + new_truename = cl_truename(newn); + @(return newn old_truename new_truename) @) static int @@ -589,149 +589,149 @@ cl_delete_file(cl_object file) { cl_object path = cl_pathname(file); int isdir = directory_pathname_p(path); - cl_object filename = coerce_to_posix_filename(path); - int ok, code; + cl_object filename = coerce_to_posix_filename(path); + int ok, code; - ecl_disable_interrupts(); + ecl_disable_interrupts(); ok = (isdir? rmdir : unlink)((char*)filename->base_string.self); - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (ok < 0) { + if (ok < 0) { const char *msg = isdir? "Cannot delete the directory ~S.~%C library error: ~S" : "Cannot delete the file ~S.~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); } - @(return ECL_T) + @(return ECL_T) } cl_object cl_probe_file(cl_object file) { - /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ - @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)) + /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ + @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)) } cl_object cl_file_write_date(cl_object file) { - cl_object time, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - time = ECL_NIL; - } else { - time = UTC_time_to_universal_time(filestatus.st_mtime); - } - @(return time) + cl_object time, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + time = ECL_NIL; + } else { + time = UTC_time_to_universal_time(filestatus.st_mtime); + } + @(return time) } cl_object cl_file_author(cl_object file) { - cl_object output, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - const char *msg = "Unable to read file author for ~S." - "~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } + cl_object output, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + const char *msg = "Unable to read file author for ~S." + "~%C library error: ~S"; + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } #ifdef HAVE_PWD_H - { - struct passwd *pwent; - ecl_disable_interrupts(); - pwent = getpwuid(filestatus.st_uid); - ecl_enable_interrupts(); - output = make_base_string_copy(pwent->pw_name); - } + { + struct passwd *pwent; + ecl_disable_interrupts(); + pwent = getpwuid(filestatus.st_uid); + ecl_enable_interrupts(); + output = make_base_string_copy(pwent->pw_name); + } #else - output = make_constant_base_string("UNKNOWN"); + output = make_constant_base_string("UNKNOWN"); #endif - @(return output) + @(return output) } cl_object ecl_homedir_pathname(cl_object user) { - cl_index i; - cl_object namestring; - const char *h, *d; - if (!Null(user)) { + cl_index i; + cl_object namestring; + const char *h, *d; + if (!Null(user)) { #ifdef HAVE_PWD_H - struct passwd *pwent = NULL; + struct passwd *pwent = NULL; #endif - char *p; - /* This ensures that our string has the right length - and it is terminated with a '\0' */ - user = si_copy_to_simple_base_string(user); - p = (char*)user->base_string.self; - i = user->base_string.fillp; - if (i > 0 && *p == '~') { - p++; - i--; - } - if (i == 0) - return ecl_homedir_pathname(ECL_NIL); + char *p; + /* This ensures that our string has the right length + and it is terminated with a '\0' */ + user = si_copy_to_simple_base_string(user); + p = (char*)user->base_string.self; + i = user->base_string.fillp; + if (i > 0 && *p == '~') { + p++; + i--; + } + if (i == 0) + return ecl_homedir_pathname(ECL_NIL); #ifdef HAVE_PWD_H - pwent = getpwnam(p); - if (pwent == NULL) - FEerror("Unknown user ~S.", 1, p); - namestring = make_base_string_copy(pwent->pw_dir); + pwent = getpwnam(p); + if (pwent == NULL) + FEerror("Unknown user ~S.", 1, p); + namestring = make_base_string_copy(pwent->pw_dir); #endif - FEerror("Unknown user ~S.", 1, p); - } else if ((h = getenv("HOME"))) { - namestring = make_base_string_copy(h); + FEerror("Unknown user ~S.", 1, p); + } else if ((h = getenv("HOME"))) { + namestring = make_base_string_copy(h); #if defined(ECL_MS_WINDOWS_HOST) - } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { - namestring = - si_base_string_concatenate(2, - make_constant_base_string(d), - make_constant_base_string(h)); + } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { + namestring = + si_base_string_concatenate(2, + make_constant_base_string(d), + make_constant_base_string(h)); #endif - } else { - namestring = make_constant_base_string("/"); - } - if (namestring->base_string.self[0] == '~') { - FEerror("Not a valid home pathname ~S", 1, namestring); - } - i = namestring->base_string.fillp; - if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) - namestring = si_base_string_concatenate(2, namestring, - ECL_CODE_CHAR(DIR_SEPARATOR)); - return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); + } else { + namestring = make_constant_base_string("/"); + } + if (namestring->base_string.self[0] == '~') { + FEerror("Not a valid home pathname ~S", 1, namestring); + } + i = namestring->base_string.fillp; + if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) + namestring = si_base_string_concatenate(2, namestring, + ECL_CODE_CHAR(DIR_SEPARATOR)); + return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); } @(defun user_homedir_pathname (&optional host) @ - /* Ignore optional host argument. */ - @(return ecl_homedir_pathname(ECL_NIL)); + /* Ignore optional host argument. */ + @(return ecl_homedir_pathname(ECL_NIL)); @) static bool string_match(const char *s, cl_object pattern) { - if (pattern == ECL_NIL || pattern == @':wild') { - return 1; - } else { - cl_index ls = strlen(s); - ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); - return ecl_string_match(strng, 0, ls, - pattern, 0, ecl_length(pattern)); - } + if (pattern == ECL_NIL || pattern == @':wild') { + return 1; + } else { + cl_index ls = strlen(s); + ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); + return ecl_string_match(strng, 0, ls, + pattern, 0, ecl_length(pattern)); + } } /* @@ -744,75 +744,75 @@ static cl_object list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask, int flags) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object out = ECL_NIL; - cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); - cl_object component, component_path, kind; - char *text; + const cl_env_ptr the_env = ecl_process_env(); + cl_object out = ECL_NIL; + cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); + cl_object component, component_path, kind; + char *text; #if defined(HAVE_DIRENT_H) - DIR *dir; - struct dirent *entry; + DIR *dir; + struct dirent *entry; - ecl_disable_interrupts(); - dir = opendir((char*)prefix->base_string.self); - if (dir == NULL) { - out = ECL_NIL; - goto OUTPUT; - } + ecl_disable_interrupts(); + dir = opendir((char*)prefix->base_string.self); + if (dir == NULL) { + out = ECL_NIL; + goto OUTPUT; + } - while ((entry = readdir(dir))) { - text = entry->d_name; + while ((entry = readdir(dir))) { + text = entry->d_name; #else # ifdef ECL_MS_WINDOWS_HOST - WIN32_FIND_DATA fd; - HANDLE hFind = NULL; - BOOL found = FALSE; + WIN32_FIND_DATA fd; + HANDLE hFind = NULL; + BOOL found = FALSE; - ecl_disable_interrupts(); - for (;;) { - if (hFind == NULL) { - cl_object aux = make_constant_base_string(".\\*"); - cl_object mask = si_base_string_concatenate(2, prefix, aux); - hFind = FindFirstFile((char*)mask->base_string.self, &fd); - if (hFind == INVALID_HANDLE_VALUE) { - out = ECL_NIL; - goto OUTPUT; - } - found = TRUE; - } else { - found = FindNextFile(hFind, &fd); - } - if (!found) - break; - text = fd.cFileName; + ecl_disable_interrupts(); + for (;;) { + if (hFind == NULL) { + cl_object aux = make_constant_base_string(".\\*"); + cl_object mask = si_base_string_concatenate(2, prefix, aux); + hFind = FindFirstFile((char*)mask->base_string.self, &fd); + if (hFind == INVALID_HANDLE_VALUE) { + out = ECL_NIL; + goto OUTPUT; + } + found = TRUE; + } else { + found = FindNextFile(hFind, &fd); + } + if (!found) + break; + text = fd.cFileName; # else /* sys/dir.h as in SYSV */ - FILE *fp; - char iobuffer[BUFSIZ]; - DIRECTORY dir; + FILE *fp; + char iobuffer[BUFSIZ]; + DIRECTORY dir; - ecl_disable_interrupts(); - fp = fopen((char*)prefix->base_string.self, OPEN_R); - if (fp == NULL) { - out = ECL_NIL; - goto OUTPUT; - } - setbuf(fp, iobuffer); - for (;;) { - if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) - break; - if (dir.d_ino == 0) - continue; - text = dir.d_name; + ecl_disable_interrupts(); + fp = fopen((char*)prefix->base_string.self, OPEN_R); + if (fp == NULL) { + out = ECL_NIL; + goto OUTPUT; + } + setbuf(fp, iobuffer); + for (;;) { + if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) + break; + if (dir.d_ino == 0) + continue; + text = dir.d_name; # endif /* !ECL_MS_WINDOWS_HOST */ #endif /* !HAVE_DIRENT_H */ - if (text[0] == '.' && - (text[1] == '\0' || - (text[1] == '.' && text[2] == '\0'))) - continue; - if (!string_match(text, text_mask)) - continue; - component = make_constant_base_string(text); - component = si_base_string_concatenate(2, prefix, component); + if (text[0] == '.' && + (text[1] == '\0' || + (text[1] == '.' && text[2] == '\0'))) + continue; + if (!string_match(text, text_mask)) + continue; + component = make_constant_base_string(text); + component = si_base_string_concatenate(2, prefix, component); component_path = cl_pathname(component); if (!Null(pathname_mask)) { if (Null(cl_pathname_match_p(component, pathname_mask))) @@ -820,20 +820,20 @@ list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask, } component_path = file_truename(component_path, component, flags); kind = ecl_nth_value(the_env, 1); - out = CONS(CONS(component_path, kind), out); - } + out = CONS(CONS(component_path, kind), out); + } #ifdef HAVE_DIRENT_H - closedir(dir); + closedir(dir); #else # ifdef ECL_MS_WINDOWS_HOST FindClose(hFind); # else - fclose(fp); + fclose(fp); # endif /* !ECL_MS_WINDOWS_HOST */ #endif /* !HAVE_DIRENT_H */ - ecl_enable_interrupts(); + ecl_enable_interrupts(); OUTPUT: - return cl_nreverse(out); + return cl_nreverse(out); } /* @@ -846,28 +846,28 @@ OUTPUT: static cl_object dir_files(cl_object base_dir, cl_object pathname, int flags) { - cl_object all_files, output = ECL_NIL; - cl_object mask; - cl_object name = pathname->pathname.name; - cl_object type = pathname->pathname.type; - if (name == ECL_NIL && type == ECL_NIL) { - return cl_list(1, base_dir); - } - mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + cl_object all_files, output = ECL_NIL; + cl_object mask; + cl_object name = pathname->pathname.name; + cl_object type = pathname->pathname.type; + if (name == ECL_NIL && type == ECL_NIL) { + return cl_list(1, base_dir); + } + mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, name, type, pathname->pathname.version, @':local'); - for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); - !Null(all_files); - all_files = ECL_CONS_CDR(all_files)) - { - cl_object record = ECL_CONS_CAR(all_files); - cl_object new = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') { - output = CONS(new, output); - } - } - return output; + for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); + !Null(all_files); + all_files = ECL_CONS_CDR(all_files)) + { + cl_object record = ECL_CONS_CAR(all_files); + cl_object new = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') { + output = CONS(new, output); + } + } + return output; } /* @@ -879,100 +879,100 @@ dir_files(cl_object base_dir, cl_object pathname, int flags) static cl_object dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int flags) { - cl_object item, output = ECL_NIL; + cl_object item, output = ECL_NIL; AGAIN: - /* There are several possibilities here: - * - * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME - * remains to be inspected. If there is no file name or type, then - * we simply output the truename of the current directory. Otherwise - * we have to find a file which corresponds to the description. - */ - if (directory == ECL_NIL) { - return ecl_nconc(dir_files(base_dir, filemask, flags), output); - } - /* - * 2) We have not yet exhausted the DIRECTORY component of the - * pathname. We have to enter some subdirectory, determined by - * CAR(DIRECTORY) and scan it. - */ - item = ECL_CONS_CAR(directory); + /* There are several possibilities here: + * + * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME + * remains to be inspected. If there is no file name or type, then + * we simply output the truename of the current directory. Otherwise + * we have to find a file which corresponds to the description. + */ + if (directory == ECL_NIL) { + return ecl_nconc(dir_files(base_dir, filemask, flags), output); + } + /* + * 2) We have not yet exhausted the DIRECTORY component of the + * pathname. We have to enter some subdirectory, determined by + * CAR(DIRECTORY) and scan it. + */ + item = ECL_CONS_CAR(directory); - if (item == @':wild' || ecl_wild_string_p(item)) { - /* - * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to - * enter & scan all subdirectories in our curent directory. - */ - cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - ECL_CONS_CDR(directory), - filemask, flags); - output = ecl_nconc(item, output); - } - } else if (item == @':wild-inferiors') { - /* - * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do - * scan all subdirectories from _all_ levels, looking for a - * tree that matches the remaining part of DIRECTORY. - */ - cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - directory, filemask, flags); - output = ecl_nconc(item, output); - } - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ - /* - * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update - * the directory to reflect the root, the current or the parent one. - */ - base_dir = enter_directory(base_dir, item, 1); - /* - * If enter_directory() fails, we simply ignore this path. This is - * what other implementations do and is consistent with the behavior - * for the file part. - */ - if (Null(base_dir)) - return ECL_NIL; - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } - return output; + if (item == @':wild' || ecl_wild_string_p(item)) { + /* + * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to + * enter & scan all subdirectories in our curent directory. + */ + cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + ECL_CONS_CDR(directory), + filemask, flags); + output = ecl_nconc(item, output); + } + } else if (item == @':wild-inferiors') { + /* + * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do + * scan all subdirectories from _all_ levels, looking for a + * tree that matches the remaining part of DIRECTORY. + */ + cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + directory, filemask, flags); + output = ecl_nconc(item, output); + } + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ + /* + * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update + * the directory to reflect the root, the current or the parent one. + */ + base_dir = enter_directory(base_dir, item, 1); + /* + * If enter_directory() fails, we simply ignore this path. This is + * what other implementations do and is consistent with the behavior + * for the file part. + */ + if (Null(base_dir)) + return ECL_NIL; + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } + return output; } @(defun directory (mask &key (resolve_symlinks ECL_T) &allow_other_keys) cl_object base_dir; - cl_object output; + cl_object output; @ mask = coerce_to_file_pathname(mask); mask = make_absolute_pathname(mask); base_dir = make_base_pathname(mask); - output = dir_recursive(base_dir, mask->pathname.directory, mask, + output = dir_recursive(base_dir, mask->pathname.directory, mask, Null(resolve_symlinks)? 0 : FOLLOW_SYMLINKS); @(return output) @) @(defun ext::getcwd (&optional (change_d_p_d ECL_NIL)) - cl_object output; + cl_object output; @ - output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); - if (!Null(change_d_p_d)) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', output); - } - @(return output) + output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); + if (!Null(change_d_p_d)) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', output); + } + @(return output) @) cl_object @@ -989,28 +989,28 @@ si_get_library_pathname(void) } } #if defined(ECL_MS_WINDOWS_HOST) - { + { char *buffer; - HMODULE hnd; - cl_index len, ep; + HMODULE hnd; + cl_index len, ep; s = ecl_alloc_adjustable_base_string(cl_core.path_max); buffer = (char*)s->base_string.self; - ecl_disable_interrupts(); - hnd = GetModuleHandle("ecl.dll"); - len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); - ecl_enable_interrupts(); - if (len == 0) { - FEerror("GetModuleFileName failed (last error = ~S)", - 1, ecl_make_fixnum(GetLastError())); - } - s->base_string.fillp = len; + ecl_disable_interrupts(); + hnd = GetModuleHandle("ecl.dll"); + len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); + ecl_enable_interrupts(); + if (len == 0) { + FEerror("GetModuleFileName failed (last error = ~S)", + 1, ecl_make_fixnum(GetLastError())); + } + s->base_string.fillp = len; /* GetModuleFileName returns a file name. We have to strip * the directory component. */ s = cl_make_pathname(8, @':name', ECL_NIL, @':type', ECL_NIL, - @':version', ECL_NIL, + @':version', ECL_NIL, @':defaults', s); s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); - } + } #else s = make_constant_base_string(ECLDIR "/"); #endif @@ -1030,40 +1030,40 @@ si_get_library_pathname(void) } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) - cl_object previous = si_getcwd(0); - cl_object namestring; + cl_object previous = si_getcwd(0); + cl_object namestring; @ - /* This will fail if the new directory does not exist */ - directory = cl_truename(directory); - if (directory->pathname.name != ECL_NIL || - directory->pathname.type != ECL_NIL) - FEerror("~A is not a directory pathname.", 1, directory); - namestring = ecl_namestring(directory, + /* This will fail if the new directory does not exist */ + directory = cl_truename(directory); + if (directory->pathname.name != ECL_NIL || + directory->pathname.type != ECL_NIL) + FEerror("~A is not a directory pathname.", 1, directory); + namestring = ecl_namestring(directory, ECL_NAMESTRING_TRUNCATE_IF_ERROR | ECL_NAMESTRING_FORCE_BASE_STRING); - if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Can't change the current directory to ~A." - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, directory, c_error), /* format args */ - @':pathname', /* file-error options */ - directory); - } else if (change_d_p_d != ECL_NIL) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); - } - @(return previous) + if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Can't change the current directory to ~A." + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, directory, c_error), /* format args */ + @':pathname', /* file-error options */ + directory); + } else if (change_d_p_d != ECL_NIL) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); + } + @(return previous) @) cl_object si_mkdir(cl_object directory, cl_object mode) { - int modeint, ok; - cl_object filename = si_coerce_to_base_string(directory); + int modeint, ok; + cl_object filename = si_coerce_to_base_string(directory); if (ecl_unlikely(!ECL_FIXNUMP(mode) || ecl_fixnum_minusp(mode) || @@ -1073,108 +1073,108 @@ si_mkdir(cl_object directory, cl_object mode) ecl_make_fixnum(0777))); } modeint = ecl_fixnum(mode); - { - /* Ensure a clean string, without trailing slashes, - * and null terminated. */ - cl_index last = filename->base_string.fillp; - if (last > 1) { - ecl_character c = filename->base_string.self[last-1]; - if (IS_DIR_SEPARATOR(c)) - last--; - } - filename = ecl_subseq(filename, 0, last); - } - ecl_disable_interrupts(); + { + /* Ensure a clean string, without trailing slashes, + * and null terminated. */ + cl_index last = filename->base_string.fillp; + if (last > 1) { + ecl_character c = filename->base_string.self[last-1]; + if (IS_DIR_SEPARATOR(c)) + last--; + } + filename = ecl_subseq(filename, 0, last); + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - ok = mkdir((char*)filename->base_string.self); + ok = mkdir((char*)filename->base_string.self); #else - ok = mkdir((char*)filename->base_string.self, modeint); + ok = mkdir((char*)filename->base_string.self, modeint); #endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (ecl_unlikely(ok < 0)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Could not create directory ~S" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, filename, c_error), /* format args */ - @':pathname', /* file-error options */ - filename); - } - @(return filename) + if (ecl_unlikely(ok < 0)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Could not create directory ~S" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, filename, c_error), /* format args */ + @':pathname', /* file-error options */ + filename); + } + @(return filename) } cl_object si_mkstemp(cl_object template) { - cl_object output; - cl_index l; - int fd; + cl_object output; + cl_index l; + int fd; #if defined(ECL_MS_WINDOWS_HOST) - cl_object phys, dir, file; - char strTempDir[MAX_PATH]; - char strTempFileName[MAX_PATH]; - char *s; - int ok; + cl_object phys, dir, file; + char strTempDir[MAX_PATH]; + char strTempFileName[MAX_PATH]; + char *s; + int ok; - phys = cl_translate_logical_pathname(1, template); - dir = cl_make_pathname(8, - @':type', ECL_NIL, - @':name', ECL_NIL, - @':version', ECL_NIL, - @':defaults', phys); - dir = si_coerce_to_filename(dir); - file = cl_file_namestring(phys); - - l = dir->base_string.fillp; - memcpy(strTempDir, dir->base_string.self, l); - strTempDir[l] = 0; - for (s = strTempDir; *s; s++) - if (*s == '/') - *s = '\\'; + phys = cl_translate_logical_pathname(1, template); + dir = cl_make_pathname(8, + @':type', ECL_NIL, + @':name', ECL_NIL, + @':version', ECL_NIL, + @':defaults', phys); + dir = si_coerce_to_filename(dir); + file = cl_file_namestring(phys); + + l = dir->base_string.fillp; + memcpy(strTempDir, dir->base_string.self, l); + strTempDir[l] = 0; + for (s = strTempDir; *s; s++) + if (*s == '/') + *s = '\\'; - ecl_disable_interrupts(); - ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, - strTempFileName); - ecl_enable_interrupts(); - if (!ok) { - output = ECL_NIL; - } else { - l = strlen(strTempFileName); - output = ecl_alloc_simple_base_string(l); - memcpy(output->base_string.self, strTempFileName, l); - } + ecl_disable_interrupts(); + ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, + strTempFileName); + ecl_enable_interrupts(); + if (!ok) { + output = ECL_NIL; + } else { + l = strlen(strTempFileName); + output = ecl_alloc_simple_base_string(l); + memcpy(output->base_string.self, strTempFileName, l); + } #else - template = si_coerce_to_filename(template); - l = template->base_string.fillp; - output = ecl_alloc_simple_base_string(l + 6); - memcpy(output->base_string.self, template->base_string.self, l); - memcpy(output->base_string.self + l, "XXXXXX", 6); + template = si_coerce_to_filename(template); + l = template->base_string.fillp; + output = ecl_alloc_simple_base_string(l + 6); + memcpy(output->base_string.self, template->base_string.self, l); + memcpy(output->base_string.self + l, "XXXXXX", 6); - ecl_disable_interrupts(); + ecl_disable_interrupts(); # ifdef HAVE_MKSTEMP - fd = mkstemp((char*)output->base_string.self); + fd = mkstemp((char*)output->base_string.self); # else - if (mktemp((char*)output->base_string.self)) { - fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); - } else { - fd = -1; - } + if (mktemp((char*)output->base_string.self)) { + fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); + } else { + fd = -1; + } # endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (fd < 0) { - output = ECL_NIL; - } else { - close(fd); - } + if (fd < 0) { + output = ECL_NIL; + } else { + close(fd); + } #endif - @(return (Null(output)? output : cl_truename(output))) + @(return (Null(output)? output : cl_truename(output))) } cl_object @@ -1188,47 +1188,47 @@ si_rmdir(cl_object directory) cl_object si_copy_file(cl_object orig, cl_object dest) { - FILE *in, *out; - int ok = 0; - orig = si_coerce_to_filename(orig); - dest = si_coerce_to_filename(dest); - ecl_disable_interrupts(); - in = fopen((char*)orig->base_string.self, OPEN_R); - if (in) { - out = fopen((char*)dest->base_string.self, OPEN_W); - if (out) { - unsigned char *buffer = ecl_alloc_atomic(1024); - cl_index size; - do { - size = fread(buffer, 1, 1024, in); - fwrite(buffer, 1, size, out); - } while (size == 1024); - ok = 1; - fclose(out); - } - fclose(in); - } - ecl_enable_interrupts(); - @(return (ok? ECL_T : ECL_NIL)) + FILE *in, *out; + int ok = 0; + orig = si_coerce_to_filename(orig); + dest = si_coerce_to_filename(dest); + ecl_disable_interrupts(); + in = fopen((char*)orig->base_string.self, OPEN_R); + if (in) { + out = fopen((char*)dest->base_string.self, OPEN_W); + if (out) { + unsigned char *buffer = ecl_alloc_atomic(1024); + cl_index size; + do { + size = fread(buffer, 1, 1024, in); + fwrite(buffer, 1, size, out); + } while (size == 1024); + ok = 1; + fclose(out); + } + fclose(in); + } + ecl_enable_interrupts(); + @(return (ok? ECL_T : ECL_NIL)) } cl_object si_chmod(cl_object file, cl_object mode) { - mode_t code = ecl_to_uint32_t(mode); - cl_object filename = coerce_to_posix_filename(file); - unlikely_if (chmod((char*)filename->base_string.self, code)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to change mode of file ~S to value ~O" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(3, file, mode, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } - @(return) + mode_t code = ecl_to_uint32_t(mode); + cl_object filename = coerce_to_posix_filename(file); + unlikely_if (chmod((char*)filename->base_string.self, code)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to change mode of file ~S to value ~O" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(3, file, mode, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } + @(return) } diff --git a/src/c/unixint.d b/src/c/unixint.d index f09a4366f..5b69f6969 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -96,107 +96,107 @@ #include static struct { - int code; - char *name; - cl_object handler; + int code; + char *name; + cl_object handler; } known_signals[] = { #ifdef SIGHUP - { SIGHUP, "+SIGHUP+", ECL_NIL}, + { SIGHUP, "+SIGHUP+", ECL_NIL}, #endif #ifdef SIGINT - { SIGINT, "+SIGINT+", @'si::terminal-interrupt'}, + { SIGINT, "+SIGINT+", @'si::terminal-interrupt'}, #endif #ifdef SIGQUIT - { SIGQUIT, "+SIGQUIT+", ECL_NIL}, + { SIGQUIT, "+SIGQUIT+", ECL_NIL}, #endif #ifdef SIGILL - { SIGILL, "+SIGILL+", @'ext::illegal-instruction'}, + { SIGILL, "+SIGILL+", @'ext::illegal-instruction'}, #endif #ifdef SIGTRAP - { SIGTRAP, "+SIGTRAP+", ECL_NIL}, + { SIGTRAP, "+SIGTRAP+", ECL_NIL}, #endif #ifdef SIGABRT - { SIGABRT, "+SIGABRT+", ECL_NIL}, + { SIGABRT, "+SIGABRT+", ECL_NIL}, #endif #ifdef SIGEMT - { SIGEMT, "+SIGEMT+", ECL_NIL}, + { SIGEMT, "+SIGEMT+", ECL_NIL}, #endif #ifdef SIGFPE - { SIGFPE, "+SIGFPE+", ECL_NIL}, + { SIGFPE, "+SIGFPE+", ECL_NIL}, #endif #ifdef SIGKILL - { SIGKILL, "+SIGKILL+", ECL_NIL}, + { SIGKILL, "+SIGKILL+", ECL_NIL}, #endif #ifdef SIGBUS - { SIGBUS, "+SIGBUS+", @'ext::segmentation-violation'}, + { SIGBUS, "+SIGBUS+", @'ext::segmentation-violation'}, #endif #ifdef SIGSEGV - { SIGSEGV, "+SIGSEGV+", @'ext::segmentation-violation'}, + { SIGSEGV, "+SIGSEGV+", @'ext::segmentation-violation'}, #endif #ifdef SIGSYS - { SIGSYS, "+SIGSYS+", ECL_NIL}, + { SIGSYS, "+SIGSYS+", ECL_NIL}, #endif #ifdef SIGPIPE - { SIGPIPE, "+SIGPIPE+", ECL_NIL}, + { SIGPIPE, "+SIGPIPE+", ECL_NIL}, #endif #ifdef SIGALRM - { SIGALRM, "+SIGALRM+", ECL_NIL}, + { SIGALRM, "+SIGALRM+", ECL_NIL}, #endif #ifdef SIGTERM - { SIGTERM, "+SIGTERM+", ECL_NIL}, + { SIGTERM, "+SIGTERM+", ECL_NIL}, #endif #ifdef SIGURG - { SIGURG, "+SIGURG+", ECL_NIL}, + { SIGURG, "+SIGURG+", ECL_NIL}, #endif #ifdef SIGSTOP - { SIGSTOP, "+SIGSTOP+", ECL_NIL}, + { SIGSTOP, "+SIGSTOP+", ECL_NIL}, #endif #ifdef SIGTSTP - { SIGTSTP, "+SIGTSTP+", ECL_NIL}, + { SIGTSTP, "+SIGTSTP+", ECL_NIL}, #endif #ifdef SIGCONT - { SIGCONT, "+SIGCONT+", ECL_NIL}, + { SIGCONT, "+SIGCONT+", ECL_NIL}, #endif #ifdef SIGCHLD - { SIGCHLD, "+SIGCHLD+", @'si::wait-for-all-processes'}, + { SIGCHLD, "+SIGCHLD+", @'si::wait-for-all-processes'}, #endif #ifdef SIGTTIN - { SIGTTIN, "+SIGTTIN+", ECL_NIL}, + { SIGTTIN, "+SIGTTIN+", ECL_NIL}, #endif #ifdef SIGTTOU - { SIGTTOU, "+SIGTTOU+", ECL_NIL}, + { SIGTTOU, "+SIGTTOU+", ECL_NIL}, #endif #ifdef SIGIO - { SIGIO, "+SIGIO+", ECL_NIL}, + { SIGIO, "+SIGIO+", ECL_NIL}, #endif #ifdef SIGXCPU - { SIGXCPU, "+SIGXCPU+", ECL_NIL}, + { SIGXCPU, "+SIGXCPU+", ECL_NIL}, #endif #ifdef SIGXFSZ - { SIGXFSZ, "+SIGXFSZ+", ECL_NIL}, + { SIGXFSZ, "+SIGXFSZ+", ECL_NIL}, #endif #ifdef SIGVTALRM - { SIGVTALRM, "+SIGVTALRM+", ECL_NIL}, + { SIGVTALRM, "+SIGVTALRM+", ECL_NIL}, #endif #ifdef SIGPROF - { SIGPROF, "+SIGPROF+", ECL_NIL}, + { SIGPROF, "+SIGPROF+", ECL_NIL}, #endif #ifdef SIGWINCH - { SIGWINCH, "+SIGWINCH+", ECL_NIL}, + { SIGWINCH, "+SIGWINCH+", ECL_NIL}, #endif #ifdef SIGINFO - { SIGINFO, "+SIGINFO+", ECL_NIL}, + { SIGINFO, "+SIGINFO+", ECL_NIL}, #endif #ifdef SIGUSR1 - { SIGUSR1, "+SIGUSR1+", ECL_NIL}, + { SIGUSR1, "+SIGUSR1+", ECL_NIL}, #endif #ifdef SIGUSR2 - { SIGUSR2, "+SIGUSR2+", ECL_NIL}, + { SIGUSR2, "+SIGUSR2+", ECL_NIL}, #endif #ifdef SIGTHR - { SIGTHR, "+SIGTHR+", ECL_NIL}, + { SIGTHR, "+SIGTHR+", ECL_NIL}, #endif - { -1, "", ECL_NIL } + { -1, "", ECL_NIL } }; #ifdef HAVE_SIGPROCMASK @@ -208,23 +208,23 @@ static sigset_t main_thread_sigmask; static void mysignal(int code, void *handler) { - struct sigaction action; - sigaction(code, NULL, &action); + struct sigaction action; + sigaction(code, NULL, &action); if (handler == SIG_IGN || handler == SIG_DFL) { action.sa_handler = handler; } else { #ifdef SA_SIGINFO - /* void (*handler)(int, siginfo_t *, void*) */ + /* void (*handler)(int, siginfo_t *, void*) */ action.sa_sigaction = handler; action.sa_flags = SA_SIGINFO; #else - /* void (*handler)(int) */ + /* void (*handler)(int) */ action.sa_handler = handler; action.sa_flags = 0; #endif sigfillset(&action.sa_mask); } - sigaction(code, &action, NULL); + sigaction(code, &action, NULL); } #else /* HAVE_SIGPROCMASK */ # define handler_fn_prototype(name, sig, info, aux) name(sig) @@ -238,29 +238,29 @@ static bool zombie_process(cl_env_ptr the_env) { #ifdef ECL_THREADS - if (the_env == NULL) { - return 1; - } else { - /* When we are exiting a thread, we simply ignore all signals. */ - cl_object process = the_env->own_process; - return (process->process.phase == ECL_PROCESS_INACTIVE); - } + if (the_env == NULL) { + return 1; + } else { + /* When we are exiting a thread, we simply ignore all signals. */ + cl_object process = the_env->own_process; + return (process->process.phase == ECL_PROCESS_INACTIVE); + } #else - return !the_env; + return !the_env; #endif } static ECL_INLINE bool interrupts_disabled_by_C(cl_env_ptr the_env) { - return the_env->disable_interrupts; + return the_env->disable_interrupts; } static ECL_INLINE bool interrupts_disabled_by_lisp(cl_env_ptr the_env) { - return !ecl_option_values[ECL_OPT_BOOTED] || - Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*')); + return !ecl_option_values[ECL_OPT_BOOTED] || + Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*')); } static void early_signal_error() ecl_attr_noreturn; @@ -268,8 +268,8 @@ static void early_signal_error() ecl_attr_noreturn; static void early_signal_error() { - ecl_internal_error("Got signal before environment was installed" - " on our thread"); + ecl_internal_error("Got signal before environment was installed" + " on our thread"); } static void illegal_signal_code(cl_object code) ecl_attr_noreturn; @@ -277,7 +277,7 @@ static void illegal_signal_code(cl_object code) ecl_attr_noreturn; static void illegal_signal_code(cl_object code) { - FEerror("Unknown signal code: ~D", 1, code); + FEerror("Unknown signal code: ~D", 1, code); } /* On platforms in which mprotect() works, we block all write access @@ -288,13 +288,13 @@ static ECL_INLINE void set_guard_page(cl_env_ptr the_env) { #if defined(ECL_USE_MPROTECT) - if (mprotect(the_env, sizeof(*the_env), PROT_READ) < 0) { - ecl_internal_error("Unable to mprotect environment."); - } + if (mprotect(the_env, sizeof(*the_env), PROT_READ) < 0) { + ecl_internal_error("Unable to mprotect environment."); + } #elif defined(ECL_USE_GUARD_PAGE) - if (!VirtualProtect(the_env, sizeof(*the_env), PAGE_GUARD, NULL)) { - ecl_internal_error("Unable to mprotect environment."); - } + if (!VirtualProtect(the_env, sizeof(*the_env), PAGE_GUARD, NULL)) { + ecl_internal_error("Unable to mprotect environment."); + } #endif } @@ -306,14 +306,14 @@ static cl_object pop_signal(cl_env_ptr env); static void unblock_signal(cl_env_ptr the_env, int signal) { - /* - * We do not really "unblock" the signal, but rather restore - * ECL's default sigmask. - */ + /* + * We do not really "unblock" the signal, but rather restore + * ECL's default sigmask. + */ # ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); + pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); # else - sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL); + sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL); # endif } #endif @@ -329,19 +329,19 @@ handle_signal_now(cl_object signal_code, cl_object process) @':code', signal_code); break; case t_symbol: - /* - * When we bind a handler to a signal, it may either - * be a function, a symbol denoting a function or - * a symbol denoting a condition. - */ - if (cl_find_class(2, signal_code, ECL_NIL) != ECL_NIL) - cl_cerror(2, str_ignore_signal, signal_code); + /* + * When we bind a handler to a signal, it may either + * be a function, a symbol denoting a function or + * a symbol denoting a condition. + */ + if (cl_find_class(2, signal_code, ECL_NIL) != ECL_NIL) + cl_cerror(2, str_ignore_signal, signal_code); #ifdef ECL_THREADS - else if (!Null(process)) - _ecl_funcall3(signal_code, @':process', process); + else if (!Null(process)) + _ecl_funcall3(signal_code, @':process', process); #endif - else - _ecl_funcall1(signal_code); + else + _ecl_funcall1(signal_code); break; case t_cfun: case t_cfunfixed: @@ -357,58 +357,58 @@ handle_signal_now(cl_object signal_code, cl_object process) cl_object si_handle_signal(cl_object signal_code, cl_object process) { - handle_signal_now(signal_code, process); - @(return) + handle_signal_now(signal_code, process); + @(return) } static void handle_all_queued(cl_env_ptr env) { - while (env->pending_interrupt != ECL_NIL) { - handle_signal_now(pop_signal(env), env->own_process); - } + while (env->pending_interrupt != ECL_NIL) { + handle_signal_now(pop_signal(env), env->own_process); + } } static void queue_signal(cl_env_ptr env, cl_object code, int allocate) { - ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) { - cl_object record; - if (allocate) { - record = ecl_list1(ECL_NIL); - } else { - record = env->signal_queue; - if (record != ECL_NIL) { - env->signal_queue = ECL_CONS_CDR(record); - } - } - if (record != ECL_NIL) { - ECL_RPLACA(record, code); - env->pending_interrupt = - ecl_nconc(env->pending_interrupt, - record); - } - } ECL_WITH_SPINLOCK_END; + ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) { + cl_object record; + if (allocate) { + record = ecl_list1(ECL_NIL); + } else { + record = env->signal_queue; + if (record != ECL_NIL) { + env->signal_queue = ECL_CONS_CDR(record); + } + } + if (record != ECL_NIL) { + ECL_RPLACA(record, code); + env->pending_interrupt = + ecl_nconc(env->pending_interrupt, + record); + } + } ECL_WITH_SPINLOCK_END; } static cl_object pop_signal(cl_env_ptr env) { - cl_object record, value; - if (env->pending_interrupt == ECL_NIL) { - return ECL_NIL; - } - ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) { - record = env->pending_interrupt; - value = ECL_CONS_CAR(record); - env->pending_interrupt = ECL_CONS_CDR(record); - /* Save some conses for future use, to avoid allocating */ - if (ECL_SYMBOLP(value) || ECL_FIXNUMP(value)) { - ECL_RPLACD(record, env->signal_queue); - env->signal_queue = record; - } - } ECL_WITH_SPINLOCK_END; - return value; + cl_object record, value; + if (env->pending_interrupt == ECL_NIL) { + return ECL_NIL; + } + ECL_WITH_SPINLOCK_BEGIN(env, &env->signal_queue_spinlock) { + record = env->pending_interrupt; + value = ECL_CONS_CAR(record); + env->pending_interrupt = ECL_CONS_CDR(record); + /* Save some conses for future use, to avoid allocating */ + if (ECL_SYMBOLP(value) || ECL_FIXNUMP(value)) { + ECL_RPLACD(record, env->signal_queue); + env->signal_queue = record; + } + } ECL_WITH_SPINLOCK_END; + return value; } static void @@ -416,31 +416,31 @@ handle_or_queue(cl_env_ptr the_env, cl_object signal_code, int code) { if (Null(signal_code) || signal_code == NULL) return; - /* - * If interrupts are disabled by lisp we are not so eager on - * detecting when the interrupts become enabled again. We - * queue the signal and are done with that. - */ - if (interrupts_disabled_by_lisp(the_env)) { - queue_signal(the_env, signal_code, 0); - } - /* - * If interrupts are disabled by C, and we have not pushed a - * pending signal, save this signal and return. - */ - else if (interrupts_disabled_by_C(the_env)) { - the_env->disable_interrupts = 3; - queue_signal(the_env, signal_code, 0); - set_guard_page(the_env); - } - /* - * If interrupts are enabled, that means we are in a safe area - * and may execute arbitrary lisp code. We can thus call the - * appropriate handlers. - */ - else { + /* + * If interrupts are disabled by lisp we are not so eager on + * detecting when the interrupts become enabled again. We + * queue the signal and are done with that. + */ + if (interrupts_disabled_by_lisp(the_env)) { + queue_signal(the_env, signal_code, 0); + } + /* + * If interrupts are disabled by C, and we have not pushed a + * pending signal, save this signal and return. + */ + else if (interrupts_disabled_by_C(the_env)) { + the_env->disable_interrupts = 3; + queue_signal(the_env, signal_code, 0); + set_guard_page(the_env); + } + /* + * If interrupts are enabled, that means we are in a safe area + * and may execute arbitrary lisp code. We can thus call the + * appropriate handlers. + */ + else { if (code) unblock_signal(the_env, code); - si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */ + si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */ handle_signal_now(signal_code, the_env->own_process); } } @@ -449,16 +449,16 @@ static void handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void *data) { int old_errno = errno; - cl_env_ptr the_env; + cl_env_ptr the_env; cl_object signal_object; - reinstall_signal(sig, non_evil_signal_handler); + reinstall_signal(sig, non_evil_signal_handler); /* The lisp environment might not be installed. */ the_env = ecl_process_env(); unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, - ECL_NIL); + cl_core.known_signals, + ECL_NIL); handle_or_queue(the_env, signal_object, sig); errno = old_errno; } @@ -467,24 +467,24 @@ static void handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *data) { int old_errno = errno; - cl_env_ptr the_env; + cl_env_ptr the_env; cl_object signal_object; - reinstall_signal(sig, evil_signal_handler); + reinstall_signal(sig, evil_signal_handler); /* The lisp environment might not be installed. */ the_env = ecl_process_env(); unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, - ECL_NIL); + cl_core.known_signals, + ECL_NIL); handle_signal_now(signal_object, the_env->own_process); errno = old_errno; } #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) typedef struct { - cl_object process; - int signo; + cl_object process; + int signo; } signal_thread_message; static cl_object signal_thread_process = ECL_NIL; static signal_thread_message signal_thread_msg; @@ -495,97 +495,97 @@ static void handler_fn_prototype(deferred_signal_handler, int sig, siginfo_t *siginfo, void *data) { int old_errno = errno; - cl_env_ptr the_env; - signal_thread_message msg; - reinstall_signal(sig, deferred_signal_handler); + cl_env_ptr the_env; + signal_thread_message msg; + reinstall_signal(sig, deferred_signal_handler); /* The lisp environment might not be installed. */ the_env = ecl_process_env(); unlikely_if (zombie_process(the_env)) return; - msg.signo = sig; - msg.process = the_env->own_process; - if (msg.process == signal_thread_process) { - /* The signal handling thread may also receive signals. In - * this case we do not use the pipe, but just copy the message - * Note that read() will abort the thread will get notified. */ - signal_thread_msg = msg; - } else if (signal_thread_pipe[1] > 0) { - ecl_get_spinlock(the_env, &signal_thread_spinlock); - write(signal_thread_pipe[1], &msg, sizeof(msg)); - ecl_giveup_spinlock(&signal_thread_spinlock); - } else { - /* Nothing to do. There is no way to handle this signal because - * the responsible thread is not running */ - } + msg.signo = sig; + msg.process = the_env->own_process; + if (msg.process == signal_thread_process) { + /* The signal handling thread may also receive signals. In + * this case we do not use the pipe, but just copy the message + * Note that read() will abort the thread will get notified. */ + signal_thread_msg = msg; + } else if (signal_thread_pipe[1] > 0) { + ecl_get_spinlock(the_env, &signal_thread_spinlock); + write(signal_thread_pipe[1], &msg, sizeof(msg)); + ecl_giveup_spinlock(&signal_thread_spinlock); + } else { + /* Nothing to do. There is no way to handle this signal because + * the responsible thread is not running */ + } errno = old_errno; } static cl_object asynchronous_signal_servicing_thread() { - const cl_env_ptr the_env = ecl_process_env(); - int interrupt_signal = -1; - /* - * We block all signals except the usual interrupt thread. - */ - { - sigset_t handled_set; - sigfillset(&handled_set); - if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { - interrupt_signal = - ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - sigdelset(&handled_set, interrupt_signal); - } - pthread_sigmask(SIG_BLOCK, &handled_set, NULL); - } - /* - * We create the object for communication. We need a lock to prevent other - * threads from writing before the pipe is created. - */ - ecl_get_spinlock(the_env, &signal_thread_spinlock); - pipe(signal_thread_pipe); - ecl_giveup_spinlock(&signal_thread_spinlock); - signal_thread_msg.process = ECL_NIL; - for (;;) { - cl_object signal_code; - signal_thread_msg.process = ECL_NIL; - if (read(signal_thread_pipe[0], &signal_thread_msg, - sizeof(signal_thread_msg)) < 0) - { - /* Either the pipe errs or we have received an interrupt - * from a different thread */ - if (errno != EINTR || - signal_thread_msg.process != the_env->own_process) - break; - } - /* We have queued ourselves an interrupt event */ - if (signal_thread_msg.signo == interrupt_signal && - signal_thread_msg.process == the_env->own_process) { - break; - } + const cl_env_ptr the_env = ecl_process_env(); + int interrupt_signal = -1; + /* + * We block all signals except the usual interrupt thread. + */ + { + sigset_t handled_set; + sigfillset(&handled_set); + if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { + interrupt_signal = + ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + sigdelset(&handled_set, interrupt_signal); + } + pthread_sigmask(SIG_BLOCK, &handled_set, NULL); + } + /* + * We create the object for communication. We need a lock to prevent other + * threads from writing before the pipe is created. + */ + ecl_get_spinlock(the_env, &signal_thread_spinlock); + pipe(signal_thread_pipe); + ecl_giveup_spinlock(&signal_thread_spinlock); + signal_thread_msg.process = ECL_NIL; + for (;;) { + cl_object signal_code; + signal_thread_msg.process = ECL_NIL; + if (read(signal_thread_pipe[0], &signal_thread_msg, + sizeof(signal_thread_msg)) < 0) + { + /* Either the pipe errs or we have received an interrupt + * from a different thread */ + if (errno != EINTR || + signal_thread_msg.process != the_env->own_process) + break; + } + /* We have queued ourselves an interrupt event */ + if (signal_thread_msg.signo == interrupt_signal && + signal_thread_msg.process == the_env->own_process) { + break; + } #ifdef SIGCHLD - if (signal_thread_msg.signo == SIGCHLD) { - si_wait_for_all_processes(0); - continue; - } + if (signal_thread_msg.signo == SIGCHLD) { + si_wait_for_all_processes(0); + continue; + } #endif - signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), - cl_core.known_signals, - ECL_NIL); - if (!Null(signal_code)) { - mp_process_run_function(4, @'si::handle-signal', - @'si::handle-signal', - signal_code, - signal_thread_msg.process); - } - } + signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), + cl_core.known_signals, + ECL_NIL); + if (!Null(signal_code)) { + mp_process_run_function(4, @'si::handle-signal', + @'si::handle-signal', + signal_code, + signal_thread_msg.process); + } + } # if defined(ECL_USE_MPROTECT) - /* We might have protected our own environment */ - mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE); + /* We might have protected our own environment */ + mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE); # endif /* ECL_USE_MPROTECT */ - close(signal_thread_pipe[0]); - close(signal_thread_pipe[1]); - ecl_return0(the_env); + close(signal_thread_pipe[0]); + close(signal_thread_pipe[1]); + ecl_return0(the_env); } #endif /* ECL_THREADS && !ECL_MS_WINDOWS_HOST */ @@ -594,20 +594,20 @@ static void handler_fn_prototype(process_interrupt_handler, int sig, siginfo_t *siginfo, void *data) { int old_errno = errno; - cl_env_ptr the_env; - reinstall_signal(sig, process_interrupt_handler); + cl_env_ptr the_env; + reinstall_signal(sig, process_interrupt_handler); /* The lisp environment might not be installed. */ the_env = ecl_process_env(); if (zombie_process(the_env)) return; - if (!Null(the_env->pending_interrupt)) { - if (interrupts_disabled_by_C(the_env)) { - set_guard_page(the_env); - } else if (!interrupts_disabled_by_lisp(the_env)) { - unblock_signal(the_env, sig); - handle_all_queued(the_env); - } - } + if (!Null(the_env->pending_interrupt)) { + if (interrupts_disabled_by_C(the_env)) { + set_guard_page(the_env); + } else if (!interrupts_disabled_by_lisp(the_env)) { + unblock_signal(the_env, sig); + handle_all_queued(the_env); + } + } errno = old_errno; } #endif /* ECL_THREADS && !ECL_MS_WINDOWS_HOST */ @@ -616,93 +616,93 @@ static void handler_fn_prototype(fpe_signal_handler, int sig, siginfo_t *info, void *data) { int code; - cl_object condition; - cl_env_ptr the_env; - reinstall_signal(sig, fpe_signal_handler); + cl_object condition; + cl_env_ptr the_env; + reinstall_signal(sig, fpe_signal_handler); /* The lisp environment might not be installed. */ - unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) { - early_signal_error(); - } + unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) { + early_signal_error(); + } the_env = ecl_process_env(); unlikely_if (zombie_process(the_env)) return; - condition = @'arithmetic-error'; - code = 0; + condition = @'arithmetic-error'; + code = 0; #ifdef _MSC_VER - switch (_fpecode) { - case _FPE_INVALID: - condition = @'floating-point-invalid-operation'; - code = FE_INVALID; - break; - case _FPE_OVERFLOW: - condition = @'floating-point-overflow'; - code = FE_OVERFLOW; - break; - case _FPE_UNDERFLOW: - condition = @'floating-point-underflow'; - code = FE_UNDERFLOW; - break; - case _FPE_ZERODIVIDE: - condition = @'division-by-zero'; - code = FE_DIVBYZERO; - break; - } + switch (_fpecode) { + case _FPE_INVALID: + condition = @'floating-point-invalid-operation'; + code = FE_INVALID; + break; + case _FPE_OVERFLOW: + condition = @'floating-point-overflow'; + code = FE_OVERFLOW; + break; + case _FPE_UNDERFLOW: + condition = @'floating-point-underflow'; + code = FE_UNDERFLOW; + break; + case _FPE_ZERODIVIDE: + condition = @'division-by-zero'; + code = FE_DIVBYZERO; + break; + } #else /* !_MSC_VER */ # if defined(HAVE_FENV_H) & !defined(ECL_AVOID_FENV_H) - code = fetestexcept(FE_ALL_EXCEPT); - if (code & FE_DIVBYZERO) { - condition = @'division-by-zero'; - code = FE_DIVBYZERO; - } else if (code & FE_INVALID) { - condition = @'floating-point-invalid-operation'; - code = FE_INVALID; - } else if (code & FE_OVERFLOW) { - condition = @'floating-point-overflow'; - code = FE_OVERFLOW; - } else if (code & FE_UNDERFLOW) { - condition = @'floating-point-underflow'; - code = FE_UNDERFLOW; - } else if (code & FE_INEXACT) { - condition = @'floating-point-inexact'; - code = FE_INEXACT; - } - feclearexcept(FE_ALL_EXCEPT); + code = fetestexcept(FE_ALL_EXCEPT); + if (code & FE_DIVBYZERO) { + condition = @'division-by-zero'; + code = FE_DIVBYZERO; + } else if (code & FE_INVALID) { + condition = @'floating-point-invalid-operation'; + code = FE_INVALID; + } else if (code & FE_OVERFLOW) { + condition = @'floating-point-overflow'; + code = FE_OVERFLOW; + } else if (code & FE_UNDERFLOW) { + condition = @'floating-point-underflow'; + code = FE_UNDERFLOW; + } else if (code & FE_INEXACT) { + condition = @'floating-point-inexact'; + code = FE_INEXACT; + } + feclearexcept(FE_ALL_EXCEPT); # endif #endif /* !_MSC_VER */ #ifdef SA_SIGINFO - if (info) { - if (info->si_code == FPE_INTDIV || info->si_code == FPE_FLTDIV) { - condition = @'division-by-zero'; - code = FE_DIVBYZERO; - } else if (info->si_code == FPE_FLTOVF) { - condition = @'floating-point-overflow'; - code = FE_OVERFLOW; - } else if (info->si_code == FPE_FLTUND) { - condition = @'floating-point-underflow'; - code = FE_UNDERFLOW; - } else if (info->si_code == FPE_FLTRES) { - condition = @'floating-point-inexact'; - code = FE_INEXACT; - } else if (info->si_code == FPE_FLTINV) { - condition = @'floating-point-invalid-operation'; - code = FE_INVALID; - } - } + if (info) { + if (info->si_code == FPE_INTDIV || info->si_code == FPE_FLTDIV) { + condition = @'division-by-zero'; + code = FE_DIVBYZERO; + } else if (info->si_code == FPE_FLTOVF) { + condition = @'floating-point-overflow'; + code = FE_OVERFLOW; + } else if (info->si_code == FPE_FLTUND) { + condition = @'floating-point-underflow'; + code = FE_UNDERFLOW; + } else if (info->si_code == FPE_FLTRES) { + condition = @'floating-point-inexact'; + code = FE_INEXACT; + } else if (info->si_code == FPE_FLTINV) { + condition = @'floating-point-invalid-operation'; + code = FE_INVALID; + } + } #endif /* SA_SIGINFO */ - /* - if (code && !(code & the_env->trap_fpe_bits)) - condition = ECL_NIL; - */ - si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */ - unblock_signal(the_env, code); - handle_signal_now(condition, the_env->own_process); - /* We will not reach past this point. */ + /* + if (code && !(code & the_env->trap_fpe_bits)) + condition = ECL_NIL; + */ + si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */ + unblock_signal(the_env, code); + handle_signal_now(condition, the_env->own_process); + /* We will not reach past this point. */ } static void handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux) { - int old_errno = errno; + int old_errno = errno; static const char *stack_overflow_msg = "\n;;;\n;;; Stack overflow.\n" ";;; Jumping to the outermost toplevel prompt\n" @@ -713,79 +713,79 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux) "also kwown as 'bus or segmentation fault'.\n" ";;; Jumping to the outermost toplevel prompt\n" ";;;\n\n"; - cl_env_ptr the_env; - reinstall_signal(sig, sigsegv_handler); + cl_env_ptr the_env; + reinstall_signal(sig, sigsegv_handler); /* The lisp environment might not be installed. */ - unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) { - early_signal_error(); - } - the_env = ecl_process_env(); - unlikely_if (zombie_process(the_env)) - return; + unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) { + early_signal_error(); + } + the_env = ecl_process_env(); + unlikely_if (zombie_process(the_env)) + return; #if defined(SA_SIGINFO) # if defined(ECL_USE_MPROTECT) - /* We access the environment when it was protected. That - * means there was a pending signal. */ - if (((char*)the_env <= (char*)info->si_addr) && + /* We access the environment when it was protected. That + * means there was a pending signal. */ + if (((char*)the_env <= (char*)info->si_addr) && ((char*)info->si_addr <= (char*)(the_env+1))) { - mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE); + mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE); the_env->disable_interrupts = 0; unblock_signal(the_env, sig); - handle_all_queued(the_env); + handle_all_queued(the_env); return; - } + } # endif /* ECL_USE_MPROTECT */ # ifdef ECL_DOWN_STACK - if (sig == SIGSEGV && - (char*)info->si_addr > the_env->cs_barrier && - (char*)info->si_addr <= the_env->cs_org) { + if (sig == SIGSEGV && + (char*)info->si_addr > the_env->cs_barrier && + (char*)info->si_addr <= the_env->cs_org) { unblock_signal(the_env, sig); - ecl_unrecoverable_error(the_env, stack_overflow_msg); + ecl_unrecoverable_error(the_env, stack_overflow_msg); return; - } + } # else - if (sig == SIGSEGV && - (char*)info->si_addr < the_env->cs_barrier && - (char*)info->si_addr >= the_env->cs_org) { + if (sig == SIGSEGV && + (char*)info->si_addr < the_env->cs_barrier && + (char*)info->si_addr >= the_env->cs_org) { unblock_signal(the_env, sig); - ecl_unrecoverable_error(the_env, stack_overflow_msg); + ecl_unrecoverable_error(the_env, stack_overflow_msg); return; - } + } # endif /* ECL_DOWN_STACK */ - /* Do not attempt an error handler if we nest two serious - * errors in the same thread */ - if (the_env->fault_address == info->si_addr) { - the_env->fault_address = info->si_addr; - unblock_signal(the_env, sig); - ecl_unrecoverable_error(the_env, segv_msg); - } else { - the_env->fault_address = info->si_addr; - handle_or_queue(the_env, @'ext::segmentation-violation', sig); - } + /* Do not attempt an error handler if we nest two serious + * errors in the same thread */ + if (the_env->fault_address == info->si_addr) { + the_env->fault_address = info->si_addr; + unblock_signal(the_env, sig); + ecl_unrecoverable_error(the_env, segv_msg); + } else { + the_env->fault_address = info->si_addr; + handle_or_queue(the_env, @'ext::segmentation-violation', sig); + } #else - /* - * We cannot distinguish between a stack overflow and a simple - * access violation. Thus we assume the worst case and jump to - * the outermost handler. - */ + /* + * We cannot distinguish between a stack overflow and a simple + * access violation. Thus we assume the worst case and jump to + * the outermost handler. + */ unblock_signal(the_env, sig); - ecl_unrecoverable_error(the_env, segv_msg); + ecl_unrecoverable_error(the_env, segv_msg); #endif /* SA_SIGINFO */ - errno = old_errno; + errno = old_errno; } cl_object si_check_pending_interrupts(void) { - handle_all_queued(ecl_process_env()); - @(return) + handle_all_queued(ecl_process_env()); + @(return) } void ecl_check_pending_interrupts(cl_env_ptr env) { - handle_all_queued(env); + handle_all_queued(env); } static cl_object @@ -800,46 +800,46 @@ do_catch_signal(int code, cl_object action, cl_object process) } else if (action == @':mask' || action == @':unmask') { #ifdef HAVE_SIGPROCMASK # ifdef ECL_THREADS - /* When a process object is supplied, the changes take care - * on the process structure and will only take effect when - * the process is enabled. */ - if (ecl_t_of(process) == t_process) { - cl_env_ptr env = process->process.env; - sigset_t *handled_set = (sigset_t *)env->default_sigmask; - if (action == @':mask') { - sigaddset(handled_set, code); - } else { - sigdelset(handled_set, code); - } - return ECL_T; - } else { - sigset_t handled_set; - pthread_sigmask(SIG_SETMASK, NULL, &handled_set); - if (action == @':mask') { - sigaddset(&handled_set, code); - } else { - sigdelset(&handled_set, code); - } - pthread_sigmask(SIG_SETMASK, &handled_set, NULL); - return ECL_T; - } + /* When a process object is supplied, the changes take care + * on the process structure and will only take effect when + * the process is enabled. */ + if (ecl_t_of(process) == t_process) { + cl_env_ptr env = process->process.env; + sigset_t *handled_set = (sigset_t *)env->default_sigmask; + if (action == @':mask') { + sigaddset(handled_set, code); + } else { + sigdelset(handled_set, code); + } + return ECL_T; + } else { + sigset_t handled_set; + pthread_sigmask(SIG_SETMASK, NULL, &handled_set); + if (action == @':mask') { + sigaddset(&handled_set, code); + } else { + sigdelset(&handled_set, code); + } + pthread_sigmask(SIG_SETMASK, &handled_set, NULL); + return ECL_T; + } # else - { - sigset_t handled_set; - sigprocmask(SIG_SETMASK, NULL, &handled_set); - if (action == @':mask') { - sigaddset(&handled_set, code); - } else { - sigdelset(&handled_set, code); - } - sigprocmask(SIG_SETMASK, &handled_set, NULL); - return ECL_T; - } + { + sigset_t handled_set; + sigprocmask(SIG_SETMASK, NULL, &handled_set); + if (action == @':mask') { + sigaddset(&handled_set, code); + } else { + sigdelset(&handled_set, code); + } + sigprocmask(SIG_SETMASK, &handled_set, NULL); + return ECL_T; + } # endif /* !ECL_THREADS */ #else /* !HAVE_SIGPROCMASK */ - return ECL_NIL; + return ECL_NIL; #endif /* !HAVE_SIGPROCMASK */ - } else if (action == ECL_T || action == @':catch') { + } else if (action == ECL_T || action == @':catch') { if (code == SIGSEGV) { mysignal(code, sigsegv_handler); } @@ -849,83 +849,83 @@ do_catch_signal(int code, cl_object action, cl_object process) } #endif #ifdef SIGILL - else if (code == SIGILL) { - mysignal(SIGILL, evil_signal_handler); - } + else if (code == SIGILL) { + mysignal(SIGILL, evil_signal_handler); + } #endif #if defined(SIGCHLD) && defined(ECL_THREADS) else if (code == SIGCHLD && - ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) - { - /* Do nothing. This is taken care of in - * the asynchronous signal handler. */ + ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) + { + /* Do nothing. This is taken care of in + * the asynchronous signal handler. */ } #endif else { mysignal(code, non_evil_signal_handler); } - return ECL_T; + return ECL_T; } else { - FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, - action); - } + FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, + action); + } } cl_object si_get_signal_handler(cl_object code) { - cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); - unlikely_if (handler == OBJNULL) { - illegal_signal_code(code); - } - @(return handler) + cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + unlikely_if (handler == OBJNULL) { + illegal_signal_code(code); + } + @(return handler) } cl_object si_set_signal_handler(cl_object code, cl_object handler) { - cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); - unlikely_if (action == OBJNULL) { - illegal_signal_code(code); - } - ecl_sethash(code, cl_core.known_signals, handler); - si_catch_signal(2, code, ECL_T); - @(return handler) + cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + unlikely_if (action == OBJNULL) { + illegal_signal_code(code); + } + ecl_sethash(code, cl_core.known_signals, handler); + si_catch_signal(2, code, ECL_T); + @(return handler) } @(defun ext::catch-signal (code flag &key process) @ { - int code_int; - unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) { - illegal_signal_code(code); - } - code_int = ecl_fixnum(code); + int code_int; + unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) { + illegal_signal_code(code); + } + code_int = ecl_fixnum(code); #ifdef GBC_BOEHM # ifdef SIGSEGV - unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) && - ecl_option_values[ECL_OPT_INCREMENTAL_GC]) - FEerror("It is not allowed to change the behavior of SIGSEGV.", - 0); + unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) && + ecl_option_values[ECL_OPT_INCREMENTAL_GC]) + FEerror("It is not allowed to change the behavior of SIGSEGV.", + 0); # endif # ifdef SIGBUS - unlikely_if (code_int == SIGBUS) - FEerror("It is not allowed to change the behavior of SIGBUS.", - 0); + unlikely_if (code_int == SIGBUS) + FEerror("It is not allowed to change the behavior of SIGBUS.", + 0); # endif #endif #if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST) - unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) { - FEerror("It is not allowed to change the behavior of signal ~D", 1, + unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) { + FEerror("It is not allowed to change the behavior of signal ~D", 1, code); - } + } #endif #ifdef SIGFPE - unlikely_if (code_int == SIGFPE) { - FEerror("The signal handler for SIGPFE cannot be uninstalled. Use SI:TRAP-FPE instead.", 0); - } + unlikely_if (code_int == SIGFPE) { + FEerror("The signal handler for SIGPFE cannot be uninstalled. Use SI:TRAP-FPE instead.", 0); + } #endif - @(return do_catch_signal(code_int, flag, process)); + @(return do_catch_signal(code_int, flag, process)); } @) @@ -934,9 +934,9 @@ si_set_signal_handler(cl_object code, cl_object handler) static VOID CALLBACK wakeup_function(ULONG_PTR foo) { - cl_env_ptr env = ecl_process_env(); - volatile i = env->nvalues; - env->nvalues = i; + cl_env_ptr env = ecl_process_env(); + volatile i = env->nvalues; + env->nvalues = i; } static VOID CALLBACK @@ -953,47 +953,47 @@ do_interrupt_thread(cl_object process) # error "Cannot implement ecl_interrupt_process without guard pages" # endif HANDLE thread = (HANDLE)process->process.thread; - CONTEXT context; + CONTEXT context; void *trap_address = process->process.env; - DWORD guard = PAGE_GUARD | PAGE_READWRITE; + DWORD guard = PAGE_GUARD | PAGE_READWRITE; int ok = 1; if (SuspendThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to suspend thread ~A", 1, - process); - ok = 0; - goto EXIT; - } + FEwin32_error("Unable to suspend thread ~A", 1, + process); + ok = 0; + goto EXIT; + } process->process.interrupt = ECL_T; if (!VirtualProtect(process->process.env, - sizeof(struct cl_env_struct), - guard, - &guard)) - { - FEwin32_error("Unable to protect memory from thread ~A", - 1, process); - ok = 0; - } + sizeof(struct cl_env_struct), + guard, + &guard)) + { + FEwin32_error("Unable to protect memory from thread ~A", + 1, process); + ok = 0; + } RESUME: - if (!QueueUserAPC(wakeup_function, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); - ok = 0; - } - if (ResumeThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to resume thread ~A", 1, - process); - ok = 0; - goto EXIT; - } + if (!QueueUserAPC(wakeup_function, thread, 0)) { + FEwin32_error("Unable to queue APC call to thread ~A", + 1, process); + ok = 0; + } + if (ResumeThread(thread) == (DWORD)-1) { + FEwin32_error("Unable to resume thread ~A", 1, + process); + ok = 0; + goto EXIT; + } EXIT: return ok; # else int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; if (pthread_kill(process->process.thread, signal)) { - FElibc_error("Unable to interrupt process ~A", 1, - process); - } - return 1; + FElibc_error("Unable to interrupt process ~A", 1, + process); + } + return 1; # endif } @@ -1002,25 +1002,25 @@ ecl_interrupt_process(cl_object process, cl_object function) { /* * We first ensure that the process is active and running - * and past the initialization phase, where it has set up - * the environment. Then: + * and past the initialization phase, where it has set up + * the environment. Then: * - In Windows it sets up a trap in the stack, so that the * uncaught exception handler can catch it and process it. * - In POSIX systems it sends a user level interrupt to * the thread, which then decides how to act. * - * If FUNCTION is NIL, we just intend to wake up the process - * from some call to ecl_musleep() Queue the interrupt for any - * process stage that can potentially receive a signal */ - if (!Null(function) && - (process->process.phase >= ECL_PROCESS_BOOTING)) - { - function = si_coerce_to_function(function); - queue_signal(process->process.env, function, 1); - } - /* ... but only deliver if the process is still alive */ - if (process->process.phase == ECL_PROCESS_ACTIVE) - do_interrupt_thread(process); + * If FUNCTION is NIL, we just intend to wake up the process + * from some call to ecl_musleep() Queue the interrupt for any + * process stage that can potentially receive a signal */ + if (!Null(function) && + (process->process.phase >= ECL_PROCESS_BOOTING)) + { + function = si_coerce_to_function(function); + queue_signal(process->process.env, function, 1); + } + /* ... but only deliver if the process is still alive */ + if (process->process.phase == ECL_PROCESS_ACTIVE) + do_interrupt_thread(process); } void @@ -1028,12 +1028,12 @@ ecl_wakeup_process(cl_object process) { # ifdef ECL_WINDOWS_THREADS HANDLE thread = (HANDLE)process->process.thread; - if (!QueueUserAPC(wakeup_noop, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); - } + if (!QueueUserAPC(wakeup_noop, thread, 0)) { + FEwin32_error("Unable to queue APC call to thread ~A", + 1, process); + } # else - do_interrupt_thread(process); + do_interrupt_thread(process); # endif } #endif /* ECL_THREADS */ @@ -1044,14 +1044,14 @@ static LPTOP_LEVEL_EXCEPTION_FILTER old_W32_exception_filter = NULL; LONG WINAPI _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep) { - LONG excpt_result; - cl_env_ptr the_env = ecl_process_env(); + LONG excpt_result; + cl_env_ptr the_env = ecl_process_env(); - excpt_result = EXCEPTION_CONTINUE_EXECUTION; - switch (ep->ExceptionRecord->ExceptionCode) - { + excpt_result = EXCEPTION_CONTINUE_EXECUTION; + switch (ep->ExceptionRecord->ExceptionCode) + { /* Access to guard page */ - case STATUS_GUARD_PAGE_VIOLATION: { + case STATUS_GUARD_PAGE_VIOLATION: { cl_object process = the_env->own_process; if (!Null(process->process.interrupt)) { cl_object signal = pop_signal(the_env); @@ -1063,80 +1063,80 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep) return EXCEPTION_CONTINUE_EXECUTION; } } - /* Catch all arithmetic exceptions */ - case EXCEPTION_INT_DIVIDE_BY_ZERO: - feclearexcept(FE_ALL_EXCEPT); + /* Catch all arithmetic exceptions */ + case EXCEPTION_INT_DIVIDE_BY_ZERO: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'division-by-zero', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_INT_OVERFLOW: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_INT_OVERFLOW: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'arithmetic-error', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_DIVIDE_BY_ZERO: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'floating-point-overflow', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_OVERFLOW: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_FLT_OVERFLOW: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'floating-point-overflow', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_UNDERFLOW: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_FLT_UNDERFLOW: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'floating-point-underflow', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_INEXACT_RESULT: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_FLT_INEXACT_RESULT: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'floating-point-inexact', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_DENORMAL_OPERAND: - case EXCEPTION_FLT_INVALID_OPERATION: - feclearexcept(FE_ALL_EXCEPT); + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_INVALID_OPERATION: + feclearexcept(FE_ALL_EXCEPT); handle_signal_now(@'floating-point-invalid-operation', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_STACK_CHECK: handle_signal_now(@'arithmetic-error', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - /* Catch segmentation fault */ - case EXCEPTION_ACCESS_VIOLATION: + /* Catch segmentation fault */ + case EXCEPTION_ACCESS_VIOLATION: handle_signal_now(@'ext::segmentation-violation', the_env->own_process); return EXCEPTION_CONTINUE_EXECUTION; - /* Catch illegal instruction */ - case EXCEPTION_ILLEGAL_INSTRUCTION: - handle_signal_now(@'ext::illegal-instruction', the_env->own_process); - return EXCEPTION_CONTINUE_EXECUTION; - /* Do not catch anything else */ - default: - excpt_result = EXCEPTION_CONTINUE_SEARCH; - break; - } + /* Catch illegal instruction */ + case EXCEPTION_ILLEGAL_INSTRUCTION: + handle_signal_now(@'ext::illegal-instruction', the_env->own_process); + return EXCEPTION_CONTINUE_EXECUTION; + /* Do not catch anything else */ + default: + excpt_result = EXCEPTION_CONTINUE_SEARCH; + break; + } if (old_W32_exception_filter) return old_W32_exception_filter(ep); - return excpt_result; + return excpt_result; } static cl_object W32_handle_in_new_thread(cl_object signal_code) { - int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL); - mp_process_run_function(4, @'si::handle-signal', - @'si::handle-signal', - signal_code, ECL_NIL); - if (outside_ecl) ecl_release_current_thread(); + int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL); + mp_process_run_function(4, @'si::handle-signal', + @'si::handle-signal', + signal_code, ECL_NIL); + if (outside_ecl) ecl_release_current_thread(); } BOOL WINAPI W32_console_ctrl_handler(DWORD type) { - switch (type) - { - /* Catch CTRL-C */ - case CTRL_C_EVENT: { - cl_object function = ECL_SYM_FUN(@'si::terminal-interrupt'); - if (function) - W32_handle_in_new_thread(function); - return TRUE; - } - } - return FALSE; + switch (type) + { + /* Catch CTRL-C */ + case CTRL_C_EVENT: { + cl_object function = ECL_SYM_FUN(@'si::terminal-interrupt'); + if (function) + W32_handle_in_new_thread(function); + return TRUE; + } + } + return FALSE; } #endif /* ECL_WINDOWS_THREADS */ @@ -1144,52 +1144,52 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type) static cl_object asynchronous_signal_servicing_thread() { - const cl_env_ptr the_env = ecl_process_env(); - sigset_t handled_set; - cl_object signal_code; - int signo; - int interrupt_signal = 0; - if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { - interrupt_signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - } + const cl_env_ptr the_env = ecl_process_env(); + sigset_t handled_set; + cl_object signal_code; + int signo; + int interrupt_signal = 0; + if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { + interrupt_signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + } /* * We wait here for all signals that are blocked in all other * threads. It would be desirable to be able to wait for _all_ * signals, but this can not be done for SIGFPE, SIGSEGV, etc. */ - pthread_sigmask(SIG_SETMASK, NULL, &handled_set); - /* - * Under OS X we also have to explicitely add the signal we - * use to communicate process interrupts. For some unknown - * reason those signals may get lost. - */ - if (interrupt_signal) { - sigaddset(&handled_set, interrupt_signal); - pthread_sigmask(SIG_SETMASK, &handled_set, NULL); - } - ECL_CATCH_ALL_BEGIN(the_env) { - for (;;) { - /* Waiting may fail! */ - int status = sigwait(&handled_set, &signo); - if (status == 0) { + pthread_sigmask(SIG_SETMASK, NULL, &handled_set); + /* + * Under OS X we also have to explicitely add the signal we + * use to communicate process interrupts. For some unknown + * reason those signals may get lost. + */ + if (interrupt_signal) { + sigaddset(&handled_set, interrupt_signal); + pthread_sigmask(SIG_SETMASK, &handled_set, NULL); + } + ECL_CATCH_ALL_BEGIN(the_env) { + for (;;) { + /* Waiting may fail! */ + int status = sigwait(&handled_set, &signo); + if (status == 0) { #if 0 - if (signo == interrupt_signal) { - /* If we get this signal it may be because - * of two reasons. One is that it is just - * an awake message. Then the queue is empty - * and we continue ... */ - signal_code = pop_signal(the_env); - if (Null(signal_code)) - continue; - /* ... the other one is that we are being - * interrupted, but this only happens when - * we quit */ - break; - } + if (signo == interrupt_signal) { + /* If we get this signal it may be because + * of two reasons. One is that it is just + * an awake message. Then the queue is empty + * and we continue ... */ + signal_code = pop_signal(the_env); + if (Null(signal_code)) + continue; + /* ... the other one is that we are being + * interrupted, but this only happens when + * we quit */ + break; + } #else - if (signo == interrupt_signal) { - break; - } + if (signo == interrupt_signal) { + break; + } #endif #ifdef SIGCHLD if (signo == SIGCHLD) { @@ -1197,18 +1197,18 @@ asynchronous_signal_servicing_thread() continue; } #endif - signal_code = ecl_gethash_safe(ecl_make_fixnum(signo), - cl_core.known_signals, - ECL_NIL); - if (!Null(signal_code)) { - mp_process_run_function(3, @'si::handle-signal', - @'si::handle-signal', - signal_code); - } - } - } - } ECL_CATCH_ALL_END; - ecl_return0(the_env); + signal_code = ecl_gethash_safe(ecl_make_fixnum(signo), + cl_core.known_signals, + ECL_NIL); + if (!Null(signal_code)) { + mp_process_run_function(3, @'si::handle-signal', + @'si::handle-signal', + signal_code); + } + } + } + } ECL_CATCH_ALL_END; + ecl_return0(the_env); } #endif @@ -1220,13 +1220,13 @@ si_trap_fpe(cl_object condition, cl_object flag) # define FE_ALL_EXCEPT FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW | FE_INVALID #endif const int all = FE_ALL_EXCEPT; - int bits = 0; + int bits = 0; if (condition == @'last') { - bits = the_env->trap_fpe_bits; + bits = the_env->trap_fpe_bits; } else { if (condition == ECL_T) bits = FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW | FE_INVALID; - else if (condition == @'division-by-zero') + else if (condition == @'division-by-zero') bits = FE_DIVBYZERO; else if (condition == @'floating-point-overflow') bits = FE_OVERFLOW; @@ -1237,7 +1237,7 @@ si_trap_fpe(cl_object condition, cl_object flag) else if (condition == @'floating-point-inexact') bits = FE_INEXACT; else if (ECL_FIXNUMP(condition)) - bits = ecl_fixnum(condition) & all; + bits = ecl_fixnum(condition) & all; if (flag == ECL_NIL) { bits = the_env->trap_fpe_bits & ~bits; } else { @@ -1249,7 +1249,7 @@ si_trap_fpe(cl_object condition, cl_object flag) feclearexcept(all); # endif # if defined(ECL_MS_WINDOWS_HOST) - _fpreset(); + _fpreset(); # endif # ifdef HAVE_FEENABLEEXCEPT fedisableexcept(all & ~bits); @@ -1257,7 +1257,7 @@ si_trap_fpe(cl_object condition, cl_object flag) # endif #endif the_env->trap_fpe_bits = bits; - @(return ecl_make_fixnum(bits)) + @(return ecl_make_fixnum(bits)) } /* @@ -1273,52 +1273,52 @@ install_asynchronous_signal_handlers() # define async_handler(signal,handler,mask) #else # if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) -# define async_handler(signal,handler,mask) { \ - if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { \ - mysignal(signal, deferred_signal_handler); \ - } else { \ - mysignal(signal,handler); \ - }} +# define async_handler(signal,handler,mask) { \ + if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { \ + mysignal(signal, deferred_signal_handler); \ + } else { \ + mysignal(signal,handler); \ + }} # else -# define async_handler(signal,handler,mask) \ - mysignal(signal,handler) +# define async_handler(signal,handler,mask) \ + mysignal(signal,handler) # endif #endif #ifdef HAVE_SIGPROCMASK - sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask; + sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask; cl_core.default_sigmask_bytes = sizeof(sigset_t); # ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, NULL, sigmask); + pthread_sigmask(SIG_SETMASK, NULL, sigmask); # else sigprocmask(SIG_SETMASK, NULL, sigmask); # endif #endif #ifdef SIGINT - if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) { - async_handler(SIGINT, non_evil_signal_handler, sigmask); - } + if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) { + async_handler(SIGINT, non_evil_signal_handler, sigmask); + } #endif #ifdef SIGCHLD - if (ecl_option_values[ECL_OPT_TRAP_SIGCHLD]) { + if (ecl_option_values[ECL_OPT_TRAP_SIGCHLD]) { /* We have to set the process signal handler explicitly, * because on many platforms the default is SIG_IGN. */ - mysignal(SIGCHLD, non_evil_signal_handler); - async_handler(SIGCHLD, non_evil_signal_handler, sigmask); - } + mysignal(SIGCHLD, non_evil_signal_handler); + async_handler(SIGCHLD, non_evil_signal_handler, sigmask); + } #endif #ifdef HAVE_SIGPROCMASK # if defined(ECL_THREADS) - pthread_sigmask(SIG_SETMASK, sigmask, NULL); + pthread_sigmask(SIG_SETMASK, sigmask, NULL); # else - sigprocmask(SIG_SETMASK, sigmask, NULL); + sigprocmask(SIG_SETMASK, sigmask, NULL); # endif #endif #ifdef ECL_WINDOWS_THREADS - old_W32_exception_filter = - SetUnhandledExceptionFilter(_ecl_w32_exception_filter); - if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) { - SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE); - } + old_W32_exception_filter = + SetUnhandledExceptionFilter(_ecl_w32_exception_filter); + if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) { + SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE); + } #endif #undef async_handler } @@ -1331,24 +1331,24 @@ static void install_signal_handling_thread() { #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) - ecl_process_env()->default_sigmask = &main_thread_sigmask; - if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { - cl_object fun = - ecl_make_cfun((cl_objectfn_fixed) - asynchronous_signal_servicing_thread, - @'si::signal-servicing', - ECL_NIL, - 0); - cl_object process = - signal_thread_process = - mp_process_run_function_wait(2, + ecl_process_env()->default_sigmask = &main_thread_sigmask; + if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { + cl_object fun = + ecl_make_cfun((cl_objectfn_fixed) + asynchronous_signal_servicing_thread, + @'si::signal-servicing', + ECL_NIL, + 0); + cl_object process = + signal_thread_process = + mp_process_run_function_wait(2, @'si::signal-servicing', fun); - if (Null(process)) { - ecl_internal_error("Unable to create signal " - "servicing thread"); - } - } + if (Null(process)) { + ecl_internal_error("Unable to create signal " + "servicing thread"); + } + } #endif } @@ -1361,48 +1361,48 @@ static void install_synchronous_signal_handlers() { #ifdef SIGBUS - if (ecl_option_values[ECL_OPT_TRAP_SIGBUS]) { - do_catch_signal(SIGBUS, ECL_T, ECL_NIL); - } + if (ecl_option_values[ECL_OPT_TRAP_SIGBUS]) { + do_catch_signal(SIGBUS, ECL_T, ECL_NIL); + } #endif #ifdef SIGSEGV - if (ecl_option_values[ECL_OPT_TRAP_SIGSEGV]) { - do_catch_signal(SIGSEGV, ECL_T, ECL_NIL); - } + if (ecl_option_values[ECL_OPT_TRAP_SIGSEGV]) { + do_catch_signal(SIGSEGV, ECL_T, ECL_NIL); + } #endif #ifdef SIGPIPE - if (ecl_option_values[ECL_OPT_TRAP_SIGPIPE]) { - do_catch_signal(SIGPIPE, ECL_T, ECL_NIL); - } + if (ecl_option_values[ECL_OPT_TRAP_SIGPIPE]) { + do_catch_signal(SIGPIPE, ECL_T, ECL_NIL); + } #endif #ifdef SIGILL - if (ecl_option_values[ECL_OPT_TRAP_SIGILL]) { - do_catch_signal(SIGILL, ECL_T, ECL_NIL); - } + if (ecl_option_values[ECL_OPT_TRAP_SIGILL]) { + do_catch_signal(SIGILL, ECL_T, ECL_NIL); + } #endif - /* In order to implement MP:INTERRUPT-PROCESS, MP:PROCESS-KILL - * and the like, we use signals. This sets up a synchronous - * signal handler for that particular signal. - */ + /* In order to implement MP:INTERRUPT-PROCESS, MP:PROCESS-KILL + * and the like, we use signals. This sets up a synchronous + * signal handler for that particular signal. + */ #ifdef SIGRTMIN # define DEFAULT_THREAD_INTERRUPT_SIGNAL SIGRTMIN + 2 #else # define DEFAULT_THREAD_INTERRUPT_SIGNAL SIGUSR1 #endif #if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST) - if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { - int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - if (signal == 0) { - signal = DEFAULT_THREAD_INTERRUPT_SIGNAL; - ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, - signal); - } - mysignal(signal, process_interrupt_handler); + if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) { + int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + if (signal == 0) { + signal = DEFAULT_THREAD_INTERRUPT_SIGNAL; + ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, + signal); + } + mysignal(signal, process_interrupt_handler); #ifdef HAVE_SIGPROCMASK sigdelset(&main_thread_sigmask, signal); pthread_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL); #endif - } + } #endif } @@ -1415,17 +1415,17 @@ static void install_fpe_signal_handlers() { #ifdef SIGFPE - if (ecl_option_values[ECL_OPT_TRAP_SIGFPE]) { - mysignal(SIGFPE, fpe_signal_handler); - si_trap_fpe(ECL_T, ECL_T); + if (ecl_option_values[ECL_OPT_TRAP_SIGFPE]) { + mysignal(SIGFPE, fpe_signal_handler); + si_trap_fpe(ECL_T, ECL_T); # ifdef ECL_IEEE_FP - /* By default deactivate errors and accept - * denormals in floating point computations */ - si_trap_fpe(@'floating-point-invalid-operation', ECL_NIL); - si_trap_fpe(@'division-by-zero', ECL_NIL); - si_trap_fpe(@'floating-point-overflow', ECL_NIL); + /* By default deactivate errors and accept + * denormals in floating point computations */ + si_trap_fpe(@'floating-point-invalid-operation', ECL_NIL); + si_trap_fpe(@'division-by-zero', ECL_NIL); + si_trap_fpe(@'floating-point-overflow', ECL_NIL); # endif - } + } #endif } @@ -1436,58 +1436,58 @@ install_fpe_signal_handlers() static void add_one_signal(cl_object hash_table, int signal, cl_object name, cl_object handler) { - cl_object code = ecl_make_fixnum(signal); - cl_export2(name, cl_core.ext_package); - si_Xmake_constant(name, code); - ecl_sethash(code, hash_table, handler); + cl_object code = ecl_make_fixnum(signal); + cl_export2(name, cl_core.ext_package); + si_Xmake_constant(name, code); + ecl_sethash(code, hash_table, handler); } static void create_signal_code_constants() { - cl_object hash = - cl_core.known_signals = - cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); - int i; - for (i = 0; known_signals[i].code >= 0; i++) { - add_one_signal(hash, known_signals[i].code, - _ecl_intern(known_signals[i].name, - cl_core.ext_package), - known_signals[i].handler); - } + cl_object hash = + cl_core.known_signals = + cl__make_hash_table(@'eql', ecl_make_fixnum(128), + cl_core.rehash_size, + cl_core.rehash_threshold); + int i; + for (i = 0; known_signals[i].code >= 0; i++) { + add_one_signal(hash, known_signals[i].code, + _ecl_intern(known_signals[i].name, + cl_core.ext_package), + known_signals[i].handler); + } #ifdef SIGRTMIN - for (i = SIGRTMIN; i <= SIGRTMAX; i++) { - int intern_flag[1]; - char buffer[64]; - cl_object name; - sprintf(buffer, "+SIGRT%d+", i-SIGRTMIN); - name = ecl_intern(make_base_string_copy(buffer), - cl_core.ext_package, - intern_flag); - add_one_signal(hash, i, name, ECL_NIL); - } - add_one_signal(hash, SIGRTMIN, - _ecl_intern("+SIGRTMIN+", cl_core.ext_package), - ECL_NIL); - add_one_signal(hash, SIGRTMAX, - _ecl_intern("+SIGRTMAX+", cl_core.ext_package), - ECL_NIL); + for (i = SIGRTMIN; i <= SIGRTMAX; i++) { + int intern_flag[1]; + char buffer[64]; + cl_object name; + sprintf(buffer, "+SIGRT%d+", i-SIGRTMIN); + name = ecl_intern(make_base_string_copy(buffer), + cl_core.ext_package, + intern_flag); + add_one_signal(hash, i, name, ECL_NIL); + } + add_one_signal(hash, SIGRTMIN, + _ecl_intern("+SIGRTMIN+", cl_core.ext_package), + ECL_NIL); + add_one_signal(hash, SIGRTMAX, + _ecl_intern("+SIGRTMAX+", cl_core.ext_package), + ECL_NIL); #endif } void init_unixint(int pass) { - if (pass == 0) { - install_asynchronous_signal_handlers(); - install_synchronous_signal_handlers(); - } else { - create_signal_code_constants(); - install_fpe_signal_handlers(); - install_signal_handling_thread(); - ECL_SET(@'ext::*interrupts-enabled*', ECL_T); - ecl_process_env()->disable_interrupts = 0; - } + if (pass == 0) { + install_asynchronous_signal_handlers(); + install_synchronous_signal_handlers(); + } else { + create_signal_code_constants(); + install_fpe_signal_handlers(); + install_signal_handling_thread(); + ECL_SET(@'ext::*interrupts-enabled*', ECL_T); + ecl_process_env()->disable_interrupts = 0; + } } diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 15379a57e..f4098c317 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -45,7 +45,7 @@ cl_object si_getpid(void) { - @(return ecl_make_fixnum(getpid())) + @(return ecl_make_fixnum(getpid())) } cl_object @@ -54,7 +54,7 @@ si_getuid(void) #if defined(ECL_MS_WINDOWS_HOST) @(return ecl_make_fixnum(0)); #else - @(return ecl_make_integer(getuid())); + @(return ecl_make_integer(getuid())); #endif } @@ -64,24 +64,24 @@ ecl_def_ct_base_string(fake_out_name, "PIPE-WRITE-ENDPOINT", 19, static, const); cl_object si_make_pipe() { - cl_object output; - int fds[2], ret; + cl_object output; + int fds[2], ret; #if defined(ECL_MS_WINDOWS_HOST) - ret = _pipe(fds, 4096, _O_BINARY); + ret = _pipe(fds, 4096, _O_BINARY); #else - ret = pipe(fds); + ret = pipe(fds); #endif - if (ret < 0) { - FElibc_error("Unable to create pipe", 0); - output = ECL_NIL; - } else { - cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - output = cl_make_two_way_stream(in, out); - } - @(return output) + if (ret < 0) { + FElibc_error("Unable to create pipe", 0); + output = ECL_NIL; + } else { + cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + output = cl_make_two_way_stream(in, out); + } + @(return output) } static cl_object @@ -182,12 +182,12 @@ add_external_process(cl_env_ptr env, cl_object process) { cl_object l = ecl_list1(process); ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { ECL_RPLACD(l, cl_core.external_processes); cl_core.external_processes = l; } - ECL_WITH_SPINLOCK_END; + ECL_WITH_SPINLOCK_END; ecl_enable_interrupts_env(env); } @@ -195,33 +195,33 @@ static void remove_external_process(cl_env_ptr env, cl_object process) { ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { cl_core.external_processes = ecl_delete_eq(process, cl_core.external_processes); } - ECL_WITH_SPINLOCK_END; + ECL_WITH_SPINLOCK_END; ecl_enable_interrupts_env(env); } static cl_object find_external_process(cl_env_ptr env, cl_object pid) { - cl_object output = ECL_NIL; - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_object p; - for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (external_process_pid(process) == pid) { - output = process; - break; - } - } - } - ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); - ecl_enable_interrupts_env(env); + cl_object output = ECL_NIL; + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_object p; + for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { + cl_object process = ECL_CONS_CAR(p); + if (external_process_pid(process) == pid) { + output = process; + break; + } + } + } + ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); + ecl_enable_interrupts_env(env); return output; } #else @@ -304,11 +304,11 @@ ecl_waitpid(cl_object pid, cl_object wait) } else { cl_object p = find_external_process(env, pid); if (!Null(p)) { - set_external_process_pid(p, ECL_NIL); + set_external_process_pid(p, ECL_NIL); update_process_status(p, status, code); } if (status != @':running') { - remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes); + remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes); } } } while (1); @@ -331,7 +331,7 @@ static cl_object make_windows_handle(HANDLE h) { cl_object foreign = ecl_allocate_foreign_data(@':pointer-void', - sizeof(HANDLE*)); + sizeof(HANDLE*)); HANDLE *ph = (HANDLE*)foreign->foreign.data; *ph = h; si_set_finalizer(foreign, @'si::close-windows-handle'); @@ -346,16 +346,16 @@ make_windows_handle(HANDLE h) AGAIN: pid = external_process_pid(process); if (Null(pid)) { - /* If PID is NIL, it may be because the process failed, - * or because it is being updated by a separate thread, - * which is why we have to spin here. Note also the order - * here: status is updated _after_ code, and hence we - * check it _before_ code. */ - do { - status = external_process_status(process); - code = external_process_code(process); - ecl_musleep(0.0, 1); - } while (status == @':running'); + /* If PID is NIL, it may be because the process failed, + * or because it is being updated by a separate thread, + * which is why we have to spin here. Note also the order + * here: status is updated _after_ code, and hence we + * check it _before_ code. */ + do { + status = external_process_status(process); + code = external_process_code(process); + ecl_musleep(0.0, 1); + } while (status == @':running'); } else { status = ecl_waitpid(pid, wait); code = ecl_nth_value(the_env, 1); @@ -380,110 +380,110 @@ make_windows_handle(HANDLE h) HANDLE ecl_stream_to_HANDLE(cl_object s, bool output) { - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return INVALID_HANDLE_VALUE; - switch ((enum ecl_smmode)s->stream.mode) { + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return INVALID_HANDLE_VALUE; + switch ((enum ecl_smmode)s->stream.mode) { #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - return (HANDLE)IO_FILE_DESCRIPTOR(s); - default: { - int stream_descriptor = ecl_stream_to_handle(s, output); - return (stream_descriptor < 0)? - INVALID_HANDLE_VALUE: - (HANDLE)_get_osfhandle(stream_descriptor); - } - } + return (HANDLE)IO_FILE_DESCRIPTOR(s); + default: { + int stream_descriptor = ecl_stream_to_handle(s, output); + return (stream_descriptor < 0)? + INVALID_HANDLE_VALUE: + (HANDLE)_get_osfhandle(stream_descriptor); + } + } } #endif @(defun ext::run-program (command argv &key (input @':stream') (output @':stream') - (error @'t') (wait @'t') (environ ECL_NIL) + (error @'t') (wait @'t') (environ ECL_NIL) (if_output_exists @':supersede')) - int parent_write = 0, parent_read = 0; - int child_pid; - cl_object pid, process; - cl_object stream_write; - cl_object stream_read; - cl_object exit_status = ECL_NIL; + int parent_write = 0, parent_read = 0; + int child_pid; + cl_object pid, process; + cl_object stream_write; + cl_object stream_read; + cl_object exit_status = ECL_NIL; @ - command = si_copy_to_simple_base_string(command); - argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); - process = make_external_process(); + command = si_copy_to_simple_base_string(command); + argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); + process = make_external_process(); #if defined(ECL_MS_WINDOWS_HOST) { - BOOL ok; - STARTUPINFO st_info; - PROCESS_INFORMATION pr_info; - HANDLE child_stdout, child_stdin, child_stderr; - HANDLE current = GetCurrentProcess(); - HANDLE saved_stdout, saved_stdin, saved_stderr; - SECURITY_ATTRIBUTES attr; + BOOL ok; + STARTUPINFO st_info; + PROCESS_INFORMATION pr_info; + HANDLE child_stdout, child_stdin, child_stderr; + HANDLE current = GetCurrentProcess(); + HANDLE saved_stdout, saved_stdin, saved_stderr; + SECURITY_ATTRIBUTES attr; cl_object env_buffer; char *env = NULL; - /* Enclose each argument, as well as the file name - in double quotes, to avoid problems when these - arguments or file names have spaces */ - command = - cl_format(4, ECL_NIL, - ecl_make_simple_base_string("~S~{ ~S~}", -1), - command, argv); - command = si_copy_to_simple_base_string(command); - command = ecl_null_terminated_base_string(command); + /* Enclose each argument, as well as the file name + in double quotes, to avoid problems when these + arguments or file names have spaces */ + command = + cl_format(4, ECL_NIL, + ecl_make_simple_base_string("~S~{ ~S~}", -1), + command, argv); + command = si_copy_to_simple_base_string(command); + command = ecl_null_terminated_base_string(command); if (!Null(environ)) { env_buffer = from_list_to_execve_argument(environ, NULL); env = env_buffer->base_string.self; } - attr.nLength = sizeof(SECURITY_ATTRIBUTES); - attr.lpSecurityDescriptor = NULL; - attr.bInheritHandle = TRUE; + attr.nLength = sizeof(SECURITY_ATTRIBUTES); + attr.lpSecurityDescriptor = NULL; + attr.bInheritHandle = TRUE; AGAIN_INPUT: - if (input == @':stream') { - /* Creates a pipe that we can read from what the child - writes to it. We duplicate one extreme of the pipe - so that the child does not inherit it. */ - HANDLE tmp; - ok = CreatePipe(&child_stdin, &tmp, &attr, 0); - if (ok) { - ok = DuplicateHandle(current, tmp, current, - &tmp, 0, FALSE, - DUPLICATE_CLOSE_SOURCE | - DUPLICATE_SAME_ACCESS); - if (ok) { + if (input == @':stream') { + /* Creates a pipe that we can read from what the child + writes to it. We duplicate one extreme of the pipe + so that the child does not inherit it. */ + HANDLE tmp; + ok = CreatePipe(&child_stdin, &tmp, &attr, 0); + if (ok) { + ok = DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS); + if (ok) { #ifdef cygwin - parent_write = + parent_write = cygwin_attach_handle_to_fd (0, -1, tmp, S_IRWXU, GENERIC_WRITE); #else - parent_write = _open_osfhandle((intptr_t)tmp, + parent_write = _open_osfhandle((intptr_t)tmp, _O_WRONLY /*| _O_TEXT*/); #endif - if (parent_write < 0) - printf("open_osfhandle failed\n"); - } - } - } else if (input == @'t') { - /* The child inherits a duplicate of our input - handle. Creating a duplicate avoids problems when - the child closes it */ - input = ecl_symbol_value(@'*standard-input*'); + if (parent_write < 0) + printf("open_osfhandle failed\n"); + } + } + } else if (input == @'t') { + /* The child inherits a duplicate of our input + handle. Creating a duplicate avoids problems when + the child closes it */ + input = ecl_symbol_value(@'*standard-input*'); goto AGAIN_INPUT; } else if (Null(input)) { - child_stdin = NULL; - /*child_stdin = open("/dev/null", O_RDONLY);*/ + child_stdin = NULL; + /*child_stdin = open("/dev/null", O_RDONLY);*/ } else if (!Null(cl_streamp(input))) { /* If stream provides a handle, pass it to the child. Otherwise * complain. */ - HANDLE stream_handle = ecl_stream_to_HANDLE(input, 0); - unlikely_if (stream_handle == INVALID_HANDLE_VALUE) { + HANDLE stream_handle = ecl_stream_to_HANDLE(input, 0); + unlikely_if (stream_handle == INVALID_HANDLE_VALUE) { FEerror(":INPUT argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, input); } @@ -491,45 +491,45 @@ ecl_stream_to_HANDLE(cl_object s, bool output) /*GetStdHandle(STD_INPUT_HANDLE)*/ current, &child_stdin, 0, TRUE, DUPLICATE_SAME_ACCESS); - } else if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) { + } else if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) { input = cl_open(5, input, @':direction', @':input', @':if-does-not-exist', @':error'); goto AGAIN_INPUT; - } else { + } else { FEerror("Invalid :INPUT argument to EXT:RUN-PROGRAM", 1, input); } AGAIN_OUTPUT: - if (output == @':stream') { - /* Creates a pipe that we can write to and the - child reads from. We duplicate one extreme of the - pipe so that the child does not inherit it. */ - HANDLE tmp; - ok = CreatePipe(&tmp, &child_stdout, &attr, 0); - if (ok) { - ok = DuplicateHandle(current, tmp, current, - &tmp, 0, FALSE, - DUPLICATE_CLOSE_SOURCE | - DUPLICATE_SAME_ACCESS); - if (ok) { + if (output == @':stream') { + /* Creates a pipe that we can write to and the + child reads from. We duplicate one extreme of the + pipe so that the child does not inherit it. */ + HANDLE tmp; + ok = CreatePipe(&tmp, &child_stdout, &attr, 0); + if (ok) { + ok = DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS); + if (ok) { #ifdef cygwin - parent_read = + parent_read = cygwin_attach_handle_to_fd (0, -1, tmp, S_IRWXU, GENERIC_READ); #else - parent_read = _open_osfhandle((intptr_t)tmp, + parent_read = _open_osfhandle((intptr_t)tmp, _O_RDONLY /*| _O_TEXT*/); #endif - if (parent_read < 0) - printf("open_osfhandle failed\n"); - } - } - } else if (output == @'t') { - /* The child inherits a duplicate of our output - handle. Creating a duplicate avoids problems when - the child closes it */ - output = ecl_symbol_value(@'*standard-output*'); + if (parent_read < 0) + printf("open_osfhandle failed\n"); + } + } + } else if (output == @'t') { + /* The child inherits a duplicate of our output + handle. Creating a duplicate avoids problems when + the child closes it */ + output = ecl_symbol_value(@'*standard-output*'); goto AGAIN_OUTPUT; } else if (Null(output)) { child_stdout = NULL; @@ -540,7 +540,7 @@ ecl_stream_to_HANDLE(cl_object s, bool output) @':if-does-not-exist', @':create'); goto AGAIN_OUTPUT; } else if (!Null(cl_streamp(output))) { - HANDLE stream_handle = ecl_stream_to_HANDLE(output, 1); + HANDLE stream_handle = ecl_stream_to_HANDLE(output, 1); unlikely_if(stream_handle == INVALID_HANDLE_VALUE) { FEerror(":OUTPUT argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, output); @@ -549,28 +549,28 @@ ecl_stream_to_HANDLE(cl_object s, bool output) /*GetStdHandle(STD_OUTPUT_HANDLE)*/ current, &child_stdout, 0, TRUE, DUPLICATE_SAME_ACCESS); - } else { + } else { FEerror("Invalid :OUTPUT argument to EXT:RUN-PROGRAM", 1, output); } AGAIN_ERROR: - if (error == @':output') { - /* The child inherits a duplicate of its own output - handle.*/ - DuplicateHandle(current, child_stdout, current, - &child_stderr, 0, TRUE, - DUPLICATE_SAME_ACCESS); - } else if (error == @'t') { - /* The child inherits a duplicate of our output - handle. Creating a duplicate avoids problems when - the child closes it */ - error = ecl_symbol_value(@'*error-output*'); + if (error == @':output') { + /* The child inherits a duplicate of its own output + handle.*/ + DuplicateHandle(current, child_stdout, current, + &child_stderr, 0, TRUE, + DUPLICATE_SAME_ACCESS); + } else if (error == @'t') { + /* The child inherits a duplicate of our output + handle. Creating a duplicate avoids problems when + the child closes it */ + error = ecl_symbol_value(@'*error-output*'); goto AGAIN_ERROR; } else if (Null(error)) { - child_stderr = NULL; + child_stderr = NULL; } else if (!Null(cl_streamp(error))) { - HANDLE stream_handle = ecl_stream_to_HANDLE(error, 1); - unlikely_if (stream_handle == INVALID_HANDLE_VALUE) { + HANDLE stream_handle = ecl_stream_to_HANDLE(error, 1); + unlikely_if (stream_handle == INVALID_HANDLE_VALUE) { FEerror(":ERROR argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, error); } @@ -578,113 +578,113 @@ ecl_stream_to_HANDLE(cl_object s, bool output) /*GetStdHandle(STD_ERROR_HANDLE)*/ current, &child_stderr, 0, TRUE, DUPLICATE_SAME_ACCESS); - } else { + } else { FEerror("Invalid :ERROR argument to EXT:RUN-PROGRAM:~%~S", 1, error); - } - add_external_process(the_env, process); + } + add_external_process(the_env, process); #if 1 - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - st_info.lpTitle = NULL; /* No window title, just exec name */ - st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ - st_info.wShowWindow = SW_HIDE; - st_info.hStdInput = child_stdin; - st_info.hStdOutput = child_stdout; - st_info.hStdError = child_stderr; - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, - env, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + st_info.lpTitle = NULL; /* No window title, just exec name */ + st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ + st_info.wShowWindow = SW_HIDE; + st_info.hStdInput = child_stdin; + st_info.hStdOutput = child_stdout; + st_info.hStdError = child_stderr; + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, + env, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ #else /* 1 */ - saved_stdin = GetStdHandle(STD_INPUT_HANDLE); - saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); - saved_stderr = GetStdHandle(STD_ERROR_HANDLE); - SetStdHandle(STD_INPUT_HANDLE, child_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); - SetStdHandle(STD_ERROR_HANDLE, child_stderr); - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0, - NULL, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ - SetStdHandle(STD_INPUT_HANDLE, saved_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); - SetStdHandle(STD_ERROR_HANDLE, saved_stderr); + saved_stdin = GetStdHandle(STD_INPUT_HANDLE); + saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); + saved_stderr = GetStdHandle(STD_ERROR_HANDLE); + SetStdHandle(STD_INPUT_HANDLE, child_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); + SetStdHandle(STD_ERROR_HANDLE, child_stderr); + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0, + NULL, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ + SetStdHandle(STD_INPUT_HANDLE, saved_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); + SetStdHandle(STD_ERROR_HANDLE, saved_stderr); #endif /* 1 */ - /* Child handles must be closed in the parent process */ - /* otherwise the created pipes are never closed */ - if (ok) { - CloseHandle(pr_info.hThread); + /* Child handles must be closed in the parent process */ + /* otherwise the created pipes are never closed */ + if (ok) { + CloseHandle(pr_info.hThread); pid = make_windows_handle(pr_info.hProcess); - } else { - char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - printf("%s\n", message); - LocalFree(message); - pid = ECL_NIL; - } + } else { + char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + printf("%s\n", message); + LocalFree(message); + pid = ECL_NIL; + } set_external_process_pid(process, pid); if (child_stdin) CloseHandle(child_stdin); - if (child_stdout) CloseHandle(child_stdout); - if (child_stderr) CloseHandle(child_stderr); + if (child_stdout) CloseHandle(child_stdout); + if (child_stderr) CloseHandle(child_stderr); } #else /* mingw */ { - int child_stdin, child_stdout, child_stderr; - int pipe_fd[2]; - argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); - argv = _ecl_funcall3(@'coerce', argv, @'vector'); + int child_stdin, child_stdout, child_stderr; + int pipe_fd[2]; + argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); + argv = _ecl_funcall3(@'coerce', argv, @'vector'); AGAIN_INPUT: - if (input == @':stream') { - int fd[2]; - pipe(fd); - parent_write = fd[1]; - child_stdin = fd[0]; - } else if (input == @'t') { + if (input == @':stream') { + int fd[2]; + pipe(fd); + parent_write = fd[1]; + child_stdin = fd[0]; + } else if (input == @'t') { input = ecl_symbol_value(@'*standard-input*'); goto AGAIN_INPUT; } else if (Null(input)) { child_stdin = open("/dev/null", O_RDONLY); } else if (!Null(cl_streamp(input))) { child_stdin = ecl_stream_to_handle(input, 0); - if (child_stdin >= 0) { - child_stdin = dup(child_stdin); + if (child_stdin >= 0) { + child_stdin = dup(child_stdin); } else { FEerror(":INPUT argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, input); } - } else if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) { + } else if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) { input = cl_open(5, input, @':direction', @':input', @':if-does-not-exist', @':error'); goto AGAIN_INPUT; - } else { + } else { FEerror("Invalid :INPUT argument to EXT:RUN-PROGRAM:~%~S", 1, input); } AGAIN_OUTPUT: - if (output == @':stream') { - int fd[2]; - pipe(fd); - parent_read = fd[0]; - child_stdout = fd[1]; - } else if (output == @'t') { + if (output == @':stream') { + int fd[2]; + pipe(fd); + parent_read = fd[0]; + child_stdout = fd[1]; + } else if (output == @'t') { output = ecl_symbol_value(@'*standard-output*'); goto AGAIN_OUTPUT; } else if (Null(output)) { @@ -697,64 +697,64 @@ ecl_stream_to_HANDLE(cl_object s, bool output) goto AGAIN_OUTPUT; } else if (!Null(cl_streamp(output))) { child_stdout = ecl_stream_to_handle(output, 1); - unlikely_if (child_stdout < 0) { + unlikely_if (child_stdout < 0) { FEerror(":OUTPUT argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, output); } child_stdout = dup(child_stdout); - } else { + } else { FEerror("Invalid :OUTPUT argument to EXT:RUN-PROGRAM:~%~S", 1, output); } AGAIN_ERROR: - if (error == @':output') { - child_stderr = child_stdout; - } else if (error == @'t') { - error = ecl_symbol_value(@'*error-output*'); + if (error == @':output') { + child_stderr = child_stdout; + } else if (error == @'t') { + error = ecl_symbol_value(@'*error-output*'); goto AGAIN_ERROR; } else if (!Null(cl_streamp(error))) { - child_stderr = ecl_stream_to_handle(error, 1); - unlikely_if (child_stderr < 0) { + child_stderr = ecl_stream_to_handle(error, 1); + unlikely_if (child_stderr < 0) { FEerror(":ERROR argument to RUN-PROGRAM does not " "have a file handle:~%~S", 1, error); } - child_stderr = dup(child_stderr); - } else if (Null(error)) { + child_stderr = dup(child_stderr); + } else if (Null(error)) { child_stderr = open("/dev/null", O_WRONLY); } else { FEerror("Invalid :ERROR argument to EXT:RUN-PROGRAM:~%~S", 1, error); - } - add_external_process(the_env, process); - pipe(pipe_fd); - child_pid = fork(); - if (child_pid == 0) { - /* Child */ - int j; - void **argv_ptr = (void **)argv->vector.self.t; - { - /* Wait for the parent to set up its process structure */ - char sync[1]; - close(pipe_fd[1]); - while (read(pipe_fd[0], sync, 1) < 1) { - printf("\nError reading child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[0]); - } - dup2(child_stdin, STDIN_FILENO); - if (parent_write) close(parent_write); - dup2(child_stdout, STDOUT_FILENO); - if (parent_read) close(parent_read); - dup2(child_stderr, STDERR_FILENO); - for (j = 0; j < argv->vector.fillp; j++) { - cl_object arg = argv->vector.self.t[j]; - if (arg == ECL_NIL) { - argv_ptr[j] = NULL; - } else { - argv_ptr[j] = arg->base_string.self; - } - } + } + add_external_process(the_env, process); + pipe(pipe_fd); + child_pid = fork(); + if (child_pid == 0) { + /* Child */ + int j; + void **argv_ptr = (void **)argv->vector.self.t; + { + /* Wait for the parent to set up its process structure */ + char sync[1]; + close(pipe_fd[1]); + while (read(pipe_fd[0], sync, 1) < 1) { + printf("\nError reading child pipe %d", errno); + fflush(stdout); + } + close(pipe_fd[0]); + } + dup2(child_stdin, STDIN_FILENO); + if (parent_write) close(parent_write); + dup2(child_stdout, STDOUT_FILENO); + if (parent_read) close(parent_read); + dup2(child_stderr, STDERR_FILENO); + for (j = 0; j < argv->vector.fillp; j++) { + cl_object arg = argv->vector.self.t[j]; + if (arg == ECL_NIL) { + argv_ptr[j] = NULL; + } else { + argv_ptr[j] = arg->base_string.self; + } + } if (!Null(environ)) { char **pstrings; cl_object buffer = from_list_to_execve_argument(environ, @@ -763,67 +763,67 @@ ecl_stream_to_HANDLE(cl_object s, bool output) } else { execvp((char*)command->base_string.self, argv_ptr); } - /* at this point exec has failed */ - perror("exec"); - abort(); - } + /* at this point exec has failed */ + perror("exec"); + abort(); + } if (child_pid < 0) { pid = ECL_NIL; } else { pid = ecl_make_fixnum(child_pid); } set_external_process_pid(process, pid); - { - /* This guarantees that the child process does not exit - * before we have created the process structure. If we do not - * do this, the SIGPIPE signal may arrive before - * set_external_process_pid() and our call to external-process-wait - * down there may block indefinitely. */ - char sync[1]; - close(pipe_fd[0]); - while (write(pipe_fd[1], sync, 1) < 1) { - printf("\nError writing child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[1]); - } - close(child_stdin); - close(child_stdout); - close(child_stderr); + { + /* This guarantees that the child process does not exit + * before we have created the process structure. If we do not + * do this, the SIGPIPE signal may arrive before + * set_external_process_pid() and our call to external-process-wait + * down there may block indefinitely. */ + char sync[1]; + close(pipe_fd[0]); + while (write(pipe_fd[1], sync, 1) < 1) { + printf("\nError writing child pipe %d", errno); + fflush(stdout); + } + close(pipe_fd[1]); + } + close(child_stdin); + close(child_stdout); + close(child_stderr); } #endif /* mingw */ - if (Null(pid)) { - if (parent_write) close(parent_write); - if (parent_read) close(parent_read); - parent_write = 0; - parent_read = 0; + if (Null(pid)) { + if (parent_write) close(parent_write); + if (parent_read) close(parent_read); + parent_write = 0; + parent_read = 0; remove_external_process(the_env, process); - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - if (parent_write > 0) { - stream_write = ecl_make_stream_from_fd(command, parent_write, - ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_T); - } else { - parent_write = 0; - stream_write = cl_core.null_stream; - } - if (parent_read > 0) { - stream_read = ecl_make_stream_from_fd(command, parent_read, - ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_T); - } else { - parent_read = 0; - stream_read = cl_core.null_stream; - } - set_external_process_streams(process, stream_write, stream_read); - if (!Null(wait)) { + FEerror("Could not spawn subprocess to run ~S.", 1, command); + } + if (parent_write > 0) { + stream_write = ecl_make_stream_from_fd(command, parent_write, + ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_T); + } else { + parent_write = 0; + stream_write = cl_core.null_stream; + } + if (parent_read > 0) { + stream_read = ecl_make_stream_from_fd(command, parent_read, + ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_T); + } else { + parent_read = 0; + stream_read = cl_core.null_stream; + } + set_external_process_streams(process, stream_write, stream_read); + if (!Null(wait)) { exit_status = si_external_process_wait(2, process, ECL_T); exit_status = ecl_nth_value(the_env, 1); } - @(return ((parent_read || parent_write)? - cl_make_two_way_stream(stream_read, stream_write) : - ECL_NIL) + @(return ((parent_read || parent_write)? + cl_make_two_way_stream(stream_read, stream_write) : + ECL_NIL) exit_status process) @) diff --git a/src/c/vector_push.d b/src/c/vector_push.d index dea32111c..030a2e713 100644 --- a/src/c/vector_push.d +++ b/src/c/vector_push.d @@ -22,69 +22,69 @@ static cl_object extend_vector(cl_object v, cl_index amount) { - cl_object other; - cl_index new_length; - unlikely_if (!ECL_VECTORP(v)) { - FEwrong_type_nth_arg(@[vector-push-extend],1,v,@[vector]); - } - if (!ECL_ADJUSTABLE_ARRAY_P(v)) - FEerror("vector-push-extend: the array ~S is not adjustable.", - 1, v); - if (v->vector.dim >= ECL_ARRAY_DIMENSION_LIMIT) - FEerror("Can't extend the array.", 0); - if (amount == 0) - amount = v->vector.dim / 2 + 1; - new_length = v->vector.dim + amount; - if (new_length > ECL_ARRAY_DIMENSION_LIMIT) - new_length = ECL_ARRAY_DIMENSION_LIMIT; - other = si_make_vector(cl_array_element_type(v), - ecl_make_fixnum(new_length), ECL_T, - ecl_make_fixnum(v->vector.fillp), - ECL_NIL, ecl_make_fixnum(0)); - ecl_copy_subarray(other, 0, v, 0, v->vector.fillp); - return si_replace_array(v, other); + cl_object other; + cl_index new_length; + unlikely_if (!ECL_VECTORP(v)) { + FEwrong_type_nth_arg(@[vector-push-extend],1,v,@[vector]); + } + if (!ECL_ADJUSTABLE_ARRAY_P(v)) + FEerror("vector-push-extend: the array ~S is not adjustable.", + 1, v); + if (v->vector.dim >= ECL_ARRAY_DIMENSION_LIMIT) + FEerror("Can't extend the array.", 0); + if (amount == 0) + amount = v->vector.dim / 2 + 1; + new_length = v->vector.dim + amount; + if (new_length > ECL_ARRAY_DIMENSION_LIMIT) + new_length = ECL_ARRAY_DIMENSION_LIMIT; + other = si_make_vector(cl_array_element_type(v), + ecl_make_fixnum(new_length), ECL_T, + ecl_make_fixnum(v->vector.fillp), + ECL_NIL, ecl_make_fixnum(0)); + ecl_copy_subarray(other, 0, v, 0, v->vector.fillp); + return si_replace_array(v, other); } ecl_character ecl_string_push_extend(cl_object s, ecl_character c) { - switch(ecl_t_of(s)) { + switch(ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - /* We use the fact that both string types are - byte-compatible except for the data. */ - if (s->base_string.fillp >= s->base_string.dim) { - s = extend_vector(s, 0); - } - ecl_char_set(s, s->base_string.fillp++, c); - return c; - default: + case t_base_string: + /* We use the fact that both string types are + byte-compatible except for the data. */ + if (s->base_string.fillp >= s->base_string.dim) { + s = extend_vector(s, 0); + } + ecl_char_set(s, s->base_string.fillp++, c); + return c; + default: FEwrong_type_nth_arg(@[vector-push-extend],1,s,@[string]); - } + } } cl_object cl_vector_push(cl_object value, cl_object v) { - cl_index f = ecl_fixnum(cl_fill_pointer(v)); - if (f >= v->vector.dim) { - @(return ECL_NIL); - } else { - ecl_aset1(v, v->vector.fillp, value); - @(return ecl_make_fixnum(v->vector.fillp++)); - } + cl_index f = ecl_fixnum(cl_fill_pointer(v)); + if (f >= v->vector.dim) { + @(return ECL_NIL); + } else { + ecl_aset1(v, v->vector.fillp, value); + @(return ecl_make_fixnum(v->vector.fillp++)); + } } @(defun vector-push-extend (value v &optional (extent ecl_make_fixnum(0))) @ { - cl_index f = ecl_fixnum(cl_fill_pointer(v)); - if (f >= v->vector.dim) { - v = extend_vector(v, ecl_to_size(extent)); - } - ecl_aset1(v, v->vector.fillp, value); - @(return ecl_make_fixnum(v->vector.fillp++)); + cl_index f = ecl_fixnum(cl_fill_pointer(v)); + if (f >= v->vector.dim) { + v = extend_vector(v, ecl_to_size(extent)); + } + ecl_aset1(v, v->vector.fillp, value); + @(return ecl_make_fixnum(v->vector.fillp++)); } @) diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 287318003..151395268 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -22,39 +22,39 @@ ;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work. (defun make-empty-standard-class (name &key (metaclass 'standard-class) - direct-superclasses direct-slots index) + direct-superclasses direct-slots index) (declare (optimize speed (safety 0))) (let* ((the-metaclass (and metaclass (gethash metaclass si::*class-name-hash-table*))) - (class (or (gethash name si::*class-name-hash-table*) - (si:allocate-raw-instance nil the-metaclass - #.(length +standard-class-slots+))))) + (class (or (gethash name si::*class-name-hash-table*) + (si:allocate-raw-instance nil the-metaclass + #.(length +standard-class-slots+))))) (with-early-accessors (+standard-class-slots+) (when (eq name 'standard-class) - (defconstant +the-standard-class+ class) - (si:instance-class-set class class)) + (defconstant +the-standard-class+ class) + (si:instance-class-set class class)) (setf (class-id class) name - (class-direct-subclasses class) nil - (class-direct-default-initargs class) nil - (class-default-initargs class) nil - (class-finalized-p class) t - (eql-specializer-flag class) nil - (specializer-direct-methods class) nil - (specializer-direct-generic-functions class) nil - (gethash name si::*class-name-hash-table*) class - (class-sealedp class) nil - (class-dependents class) nil - (class-valid-initargs class) nil - ) + (class-direct-subclasses class) nil + (class-direct-default-initargs class) nil + (class-default-initargs class) nil + (class-finalized-p class) t + (eql-specializer-flag class) nil + (specializer-direct-methods class) nil + (specializer-direct-generic-functions class) nil + (gethash name si::*class-name-hash-table*) class + (class-sealedp class) nil + (class-dependents class) nil + (class-valid-initargs class) nil + ) (add-slots class direct-slots) (let ((superclasses (loop for name in direct-superclasses - for parent = (find-class name) - do (push class (class-direct-subclasses parent)) - collect parent))) - (setf (class-direct-superclasses class) superclasses - (class-precedence-list class) - (compute-clos-class-precedence-list class superclasses))) + for parent = (find-class name) + do (push class (class-direct-subclasses parent)) + collect parent))) + (setf (class-direct-superclasses class) superclasses + (class-precedence-list class) + (compute-clos-class-precedence-list class superclasses))) (when index - (setf (aref +builtin-classes-pre-array+ index) class)) + (setf (aref +builtin-classes-pre-array+ index) class)) class))) (defun remove-accessors (slotds) @@ -66,33 +66,33 @@ (defun add-slots (class slots) (declare (si::c-local) - (optimize speed (safety 0))) + (optimize speed (safety 0))) ;; It does not matter that we pass NIL instead of a class object, ;; because CANONICAL-SLOT-TO-DIRECT-SLOT will make simple slots. (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (let* ((table (make-hash-table :size (if slots 24 0))) - (location-table (make-hash-table :size (if slots 24 0))) - (slots (parse-slots slots)) - (direct-slots (loop for slotd in slots - collect (apply #'make-simple-slotd - (find-class 'standard-direct-slot-definition) - slotd))) - (effective-slots (loop for i from 0 - for slotd in slots - for name = (getf slotd :name) - for s = (apply #'make-simple-slotd - (find-class 'standard-effective-slot-definition) - slotd) - do (setf (slot-definition-location s) i - (gethash name location-table) i - (gethash name table) s) - collect s))) + (location-table (make-hash-table :size (if slots 24 0))) + (slots (parse-slots slots)) + (direct-slots (loop for slotd in slots + collect (apply #'make-simple-slotd + (find-class 'standard-direct-slot-definition) + slotd))) + (effective-slots (loop for i from 0 + for slotd in slots + for name = (getf slotd :name) + for s = (apply #'make-simple-slotd + (find-class 'standard-effective-slot-definition) + slotd) + do (setf (slot-definition-location s) i + (gethash name location-table) i + (gethash name table) s) + collect s))) (setf (class-slots class) effective-slots - (class-direct-slots class) direct-slots - (class-size class) (length slots) - (slot-table class) table - (class-location-table class) location-table)))) + (class-direct-slots class) direct-slots + (class-size class) (length slots) + (slot-table class) table + (class-location-table class) location-table)))) ;; 1) Create the classes ;; @@ -101,8 +101,8 @@ ;; (let* ((class-hierarchy '#.+class-hierarchy+)) (let ((all-classes (loop for c in class-hierarchy - for class = (apply #'make-empty-standard-class c) - collect class))) + for class = (apply #'make-empty-standard-class c) + collect class))) (defconstant +the-t-class+ (find-class 't nil)) (defconstant +the-class+ (find-class 'class nil)) (defconstant +the-std-class+ (find-class 'std-class nil)) @@ -126,8 +126,8 @@ ;; (with-early-accessors (+standard-class-slots+) (loop for c in all-classes - do (loop for s in (class-direct-slots c) - do (si::instance-sig-set s)) - do (loop for s in (class-slots c) - do (si::instance-sig-set s)))) + do (loop for s in (class-direct-slots c) + do (si::instance-sig-set s)) + do (loop for s in (class-slots c) + do (si::instance-sig-set s)))) )) diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index 0effca669..cd1cb2e5f 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -76,7 +76,7 @@ (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) (apply #'si::make-structure class - (make-list (class-size class) :initial-element (si::unbound)))) + (make-list (class-size class) :initial-element (si::unbound)))) (defmethod finalize-inheritance ((class structure-class)) (call-next-method) @@ -89,26 +89,26 @@ (defmethod print-object ((obj structure-object) stream) (let* ((class (si:instance-class obj)) - (slotds (class-slots class))) + (slotds (class-slots class))) (declare (:read-only class)) (when (and slotds ;; *p-readably* effectively disables *p-level* - (not *print-readably*) - *print-level* - (zerop *print-level*)) + (not *print-readably*) + *print-level* + (zerop *print-level*)) (write-string "#" stream) (return-from print-object obj)) (write-string "#S(" stream) (prin1 (class-name class) stream) (do ((scan slotds (cdr scan)) - (i 0 (1+ i)) - (limit (or *print-length* most-positive-fixnum)) - (sv)) - ((null scan)) + (i 0 (1+ i)) + (limit (or *print-length* most-positive-fixnum)) + (sv)) + ((null scan)) (declare (fixnum i)) (when (>= i limit) - (write-string " ..." stream) - (return)) + (write-string " ..." stream) + (return)) (setq sv (si:instance-ref obj i)) (write-string " :" stream) (prin1 (slot-definition-name (car scan)) stream) diff --git a/src/clos/change.lsp b/src/clos/change.lsp index f300525f1..4405574ed 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -20,27 +20,27 @@ ;;; ;;; The method CHANGE-CLASS performs most of the work. ;;; -;;; a) The structure of the instance is changed to match the new -;;; number of local slots. -;;; b) The new local slots are filled with the value of the old -;;; slots. Only the name is used, so that a new local slot may -;;; get the value of old slots that were eithe local or shared. -;;; c) Finally, UPDATE-INSTANCE-FOR-DIFFERENT-CLASS is invoked -;;; with a copy of the instance as it looked before the change, -;;; the changed instance and enough information to perform any -;;; extra processing. +;;; a) The structure of the instance is changed to match the new +;;; number of local slots. +;;; b) The new local slots are filled with the value of the old +;;; slots. Only the name is used, so that a new local slot may +;;; get the value of old slots that were eithe local or shared. +;;; c) Finally, UPDATE-INSTANCE-FOR-DIFFERENT-CLASS is invoked +;;; with a copy of the instance as it looked before the change, +;;; the changed instance and enough information to perform any +;;; extra processing. ;;; (defmethod update-instance-for-different-class ((old-data standard-object) (new-data standard-object) &rest initargs) (let ((old-local-slotds (si::instance-sig old-data)) - (new-local-slotds (remove :instance (si::instance-sig new-data) - :test-not #'eq :key #'slot-definition-allocation)) - added-slots) + (new-local-slotds (remove :instance (si::instance-sig new-data) + :test-not #'eq :key #'slot-definition-allocation)) + added-slots) (setf added-slots (set-difference (mapcar #'slot-definition-name new-local-slotds) - (mapcar #'slot-definition-name old-local-slotds))) + (mapcar #'slot-definition-name old-local-slotds))) (check-initargs (class-of new-data) initargs - (valid-keywords-from-methods + (valid-keywords-from-methods (compute-applicable-methods #'update-instance-for-different-class (list old-data new-data)) @@ -49,10 +49,10 @@ (apply #'shared-initialize new-data added-slots initargs))) (defmethod change-class ((instance standard-object) (new-class std-class) - &rest initargs) + &rest initargs) (let* ((old-instance (si::copy-instance instance)) - (new-size (class-size new-class)) - (instance (si::allocate-raw-instance instance new-class new-size))) + (new-size (class-size new-class)) + (instance (si::allocate-raw-instance instance new-class new-size))) (si::instance-sig-set instance) ;; "The values of local slots specified by both the class Cto and ;; Cfrom are retained. If such a local slot was unbound, it remains @@ -61,15 +61,15 @@ ;; as local in the class Cto are retained." (let* ((new-local-slotds (class-slots (class-of instance)))) (dolist (new-slot new-local-slotds) - ;; CHANGE-CLASS can only operate on the value of local slots. - (when (eq (slot-definition-allocation new-slot) :INSTANCE) - (let ((name (slot-definition-name new-slot))) - (if (and (slot-exists-p old-instance name) - (slot-boundp old-instance name)) - (setf (slot-value instance name) (slot-value old-instance name)) - (slot-makunbound instance name)))))) + ;; CHANGE-CLASS can only operate on the value of local slots. + (when (eq (slot-definition-allocation new-slot) :INSTANCE) + (let ((name (slot-definition-name new-slot))) + (if (and (slot-exists-p old-instance name) + (slot-boundp old-instance name)) + (setf (slot-value instance name) (slot-value old-instance name)) + (slot-makunbound instance name)))))) (apply #'update-instance-for-different-class old-instance instance - initargs) + initargs) instance)) (defmethod change-class ((instance class) new-class &rest initargs) @@ -84,7 +84,7 @@ ;;; Each instance has a hidden field (readable with SI::INSTANCE-SIG), which ;;; contains the list of slots of its class. This field is updated every time ;;; the class is initialized or reinitialized. Generally -;;; (EQ (SI::INSTANCE-SIG x) (CLASS-SLOTS (CLASS-OF x))) +;;; (EQ (SI::INSTANCE-SIG x) (CLASS-SLOTS (CLASS-OF x))) ;;; returns NIL whenever the class became obsolete. ;;; ;;; There are two circumstances under which a instance may become obsolete: @@ -94,14 +94,14 @@ ;;; The function UPDATE-INSTANCE (hidden to the user) does the job of ;;; updating an instance that has become obsolete. ;;; -;;; a) A copy of the instance is saved to check the old values. -;;; b) The structure of the instance is changed to match the new -;;; number of local slots. -;;; c) The new local slots are filled with the value of the old -;;; local slots. -;;; d) Finally, UPDATE-INSTANCE-FOR-REDEFINED-CLASS is invoked -;;; with enough information to perform any extra initialization, -;;; for instance of new slots. +;;; a) A copy of the instance is saved to check the old values. +;;; b) The structure of the instance is changed to match the new +;;; number of local slots. +;;; c) The new local slots are filled with the value of the old +;;; local slots. +;;; d) Finally, UPDATE-INSTANCE-FOR-REDEFINED-CLASS is invoked +;;; with enough information to perform any extra initialization, +;;; for instance of new slots. ;;; ;;; It is not clear when the function UPDATE-INSTANCE is invoked. At least ;;; this will happen whenever the functions SLOT-VALUE, (SETF SLOT-VALUE), @@ -112,7 +112,7 @@ ((instance standard-object) added-slots discarded-slots property-list &rest initargs) (check-initargs (class-of instance) initargs - (valid-keywords-from-methods + (valid-keywords-from-methods (compute-applicable-methods #'update-instance-for-redefined-class (list instance added-slots discarded-slots property-list)) @@ -139,12 +139,12 @@ (defun update-instance (instance) (let* ((class (class-of instance)) - (old-slotds (si::instance-sig instance)) - (new-slotds (class-slots class)) - (old-instance (si::copy-instance instance)) - (discarded-slots '()) - (added-slots '()) - (property-list '())) + (old-slotds (si::instance-sig instance)) + (new-slotds (class-slots class)) + (old-instance (si::copy-instance instance)) + (discarded-slots '()) + (added-slots '()) + (property-list '())) (setf instance (si::allocate-raw-instance instance class (class-size class))) (si::instance-sig-set instance) (let* ((new-i 0) @@ -159,7 +159,7 @@ (dolist (slot-name discarded-slots) (let* ((ndx (position slot-name old-local-slotds :key #'slot-definition-name))) (setf property-list - (list* slot-name (si::instance-ref old-instance ndx) property-list)))) + (list* slot-name (si::instance-ref old-instance ndx) property-list)))) (dolist (new-slot new-local-slotds) (let* ((name (slot-definition-name new-slot)) (old-i (position name old-local-slotds :key #'slot-definition-name))) @@ -175,11 +175,11 @@ ;;; CLASS REDEFINITION PROTOCOL (ensure-generic-function 'reinitialize-instance - :lambda-list '(class &rest initargs)) + :lambda-list '(class &rest initargs)) (defmethod reinitialize-instance ((class class) &rest initargs - &key (direct-superclasses () direct-superclasses-p) - (direct-slots nil direct-slots-p)) + &key (direct-superclasses () direct-superclasses-p) + (direct-slots nil direct-slots-p)) (let ((name (class-name class))) (when (member name '(CLASS BUILT-IN-CLASS) :test #'eq) (error "The kernel CLOS class ~S cannot be changed." name))) @@ -193,8 +193,8 @@ ;; the list of direct slots is converted to direct-slot-definitions (when direct-slots-p (setf (class-direct-slots class) - (loop for s in direct-slots - collect (canonical-slot-to-direct-slot class s)))) + (loop for s in direct-slots + collect (canonical-slot-to-direct-slot class s)))) ;; set up inheritance checking that it makes sense (when direct-superclasses-p @@ -204,7 +204,7 @@ (unless (member l direct-superclasses) (remove-direct-subclass l class))) (dolist (l (setf (class-direct-superclasses class) - direct-superclasses)) + direct-superclasses)) (add-direct-subclass l class))) ;; if there are no forward references, we can just finalize the class here @@ -219,44 +219,44 @@ (defun remove-optional-slot-accessors (class) (declare (class class) - (optimize (safety 0)) - (si::c-local)) + (optimize (safety 0)) + (si::c-local)) (let ((class-name (class-name class))) (dolist (slotd (class-slots class)) ;; remove previous defined reader methods (dolist (reader (slot-definition-readers slotd)) - (let* ((gf-object (fdefinition reader)) - found) - ;; primary method - (when (setq found - (find-method gf-object nil (list class-name) nil)) - (remove-method gf-object found)) - ;; before method - (when (setq found - (find-method gf-object ':before (list class-name) nil)) - (remove-method gf-object found)) - ;; after method - (when (setq found - (find-method gf-object ':after (list class-name) nil)) - (remove-method gf-object found)) - (when (null (generic-function-methods gf-object)) - (fmakunbound reader)))) + (let* ((gf-object (fdefinition reader)) + found) + ;; primary method + (when (setq found + (find-method gf-object nil (list class-name) nil)) + (remove-method gf-object found)) + ;; before method + (when (setq found + (find-method gf-object ':before (list class-name) nil)) + (remove-method gf-object found)) + ;; after method + (when (setq found + (find-method gf-object ':after (list class-name) nil)) + (remove-method gf-object found)) + (when (null (generic-function-methods gf-object)) + (fmakunbound reader)))) ;; remove previous defined writer methods (dolist (writer (slot-definition-writers slotd)) - (let* ((gf-object (fdefinition writer)) - found) - ;; primary method - (when (setq found - (find-method gf-object nil (list 'T class-name) nil)) - (remove-method gf-object found)) - ;; before method - (when (setq found - (find-method gf-object ':before (list 'T class-name) nil)) - (remove-method gf-object found)) - ;; after method - (when (setq found - (find-method gf-object ':after (list 'T class-name) nil)) - (remove-method gf-object found)) - (when (null (generic-function-methods gf-object)) - (fmakunbound writer))))))) + (let* ((gf-object (fdefinition writer)) + found) + ;; primary method + (when (setq found + (find-method gf-object nil (list 'T class-name) nil)) + (remove-method gf-object found)) + ;; before method + (when (setq found + (find-method gf-object ':before (list 'T class-name) nil)) + (remove-method gf-object found)) + ;; after method + (when (setq found + (find-method gf-object ':after (list 'T class-name) nil)) + (remove-method gf-object found)) + (when (null (generic-function-methods gf-object)) + (fmakunbound writer))))))) diff --git a/src/clos/cmpinit.lsp b/src/clos/cmpinit.lsp index f760b9aa1..d9425e808 100644 --- a/src/clos/cmpinit.lsp +++ b/src/clos/cmpinit.lsp @@ -3,8 +3,8 @@ (defvar std-compile (symbol-function 'compile-file)) (defun compile-file (file &key (output-file (make-pathname :type "o" :defaults file))) (funcall std-compile - file - :c-file t :h-file t :data-file t :system-p t - :output-file nil)) + file + :c-file t :h-file t :data-file t :system-p t + :output-file nil)) ;(setq compiler:*cc* (concatenate 'STRING compiler:*cc* " -I../h")) diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index df490471c..5d15c0b3c 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -37,39 +37,39 @@ ;;; when these functions have been generated by previous calls ;;; to EFFECTIVE-METHOD-FUNCTION. ;;; 3) (CALL-METHOD method rest-methods) A closure is -;;; generated that invokes the current method while informing -;;; it about the remaining methods. +;;; generated that invokes the current method while informing +;;; it about the remaining methods. ;;; 4) (MAKE-METHOD form) A function is created that takes the -;;; list of arguments of the generic function and evaluates -;;; the forms in a null environment. This is the only form -;;; that may lead to consing of new bytecodes objects. Nested -;;; CALL-METHOD are handled via the global macro CALL-METHOD. +;;; list of arguments of the generic function and evaluates +;;; the forms in a null environment. This is the only form +;;; that may lead to consing of new bytecodes objects. Nested +;;; CALL-METHOD are handled via the global macro CALL-METHOD. ;;; 5) Ordinary forms are turned into lambda forms, much like -;;; what happens with the content of MAKE-METHOD. +;;; what happens with the content of MAKE-METHOD. ;;; (defun effective-method-function (form &optional top-level &aux first) (cond ((functionp form) - form) - ((method-p form) - (method-function form)) - ((atom form) - (error "Malformed effective method form:~%~A" form)) - ((eq (setf first (first form)) 'MAKE-METHOD) - (coerce `(lambda (.combined-method-args. *next-methods*) - (declare (special .combined-method-args. *next-methods*)) - ,(second form)) - 'function)) - ((eq first 'CALL-METHOD) - (combine-method-functions - (effective-method-function (second form)) - (mapcar #'effective-method-function (third form)))) - (top-level - (coerce `(lambda (.combined-method-args. no-next-methods) - (declare (ignorable no-next-methods)) - ,form) - 'function)) - (t - (error "Malformed effective method form:~%~A" form)))) + form) + ((method-p form) + (method-function form)) + ((atom form) + (error "Malformed effective method form:~%~A" form)) + ((eq (setf first (first form)) 'MAKE-METHOD) + (coerce `(lambda (.combined-method-args. *next-methods*) + (declare (special .combined-method-args. *next-methods*)) + ,(second form)) + 'function)) + ((eq first 'CALL-METHOD) + (combine-method-functions + (effective-method-function (second form)) + (mapcar #'effective-method-function (third form)))) + (top-level + (coerce `(lambda (.combined-method-args. no-next-methods) + (declare (ignorable no-next-methods)) + ,form) + 'function)) + (t + (error "Malformed effective method form:~%~A" form)))) ;;; ;;; This function is a combinator of effective methods. It creates a @@ -85,8 +85,8 @@ (defmacro call-method (method &optional rest-methods) `(funcall ,(effective-method-function method) - .combined-method-args. - ',(and rest-methods (mapcar #'effective-method-function rest-methods)))) + .combined-method-args. + ',(and rest-methods (mapcar #'effective-method-function rest-methods)))) (defun call-next-method (&rest args) (declare (special .combined-method-args. *next-methods*)) @@ -101,8 +101,8 @@ (define-compiler-macro call-next-method (&rest args) `(if *next-methods* (funcall (car *next-methods*) - ,(if args `(list ,@args) '.combined-method-args.) - (rest *next-methods*)) + ,(if args `(list ,@args) '.combined-method-args.) + (rest *next-methods*)) (error "No next method."))) (define-compiler-macro next-method-p () @@ -113,73 +113,73 @@ (error "Standard method combination allows only one qualifier ~ per method, either :BEFORE, :AFTER, or :AROUND; while ~ a method with ~S was found." - m qualifier)) + m qualifier)) (defun standard-main-effective-method (before primary after) (declare (si::c-local)) #'(lambda (.combined-method-args. no-next-method) (declare (ignorable no-next-method)) (dolist (i before) - (funcall i .combined-method-args. nil)) + (funcall i .combined-method-args. nil)) (if after - (multiple-value-prog1 - (funcall (first primary) .combined-method-args. (rest primary)) - (dolist (i after) - (funcall i .combined-method-args. nil))) - (funcall (first primary) .combined-method-args. (rest primary))))) + (multiple-value-prog1 + (funcall (first primary) .combined-method-args. (rest primary)) + (dolist (i after) + (funcall i .combined-method-args. nil))) + (funcall (first primary) .combined-method-args. (rest primary))))) (defun standard-compute-effective-method (gf methods) (with-early-accessors (+standard-method-slots+) (let* ((before ()) - (primary ()) - (after ()) - (around ())) + (primary ()) + (after ()) + (around ())) (dolist (m methods) - (let* ((qualifiers (method-qualifiers m)) - (f (method-function m))) - (cond ((null qualifiers) (push f primary)) - ((rest qualifiers) (error-qualifier m qualifiers)) - ((eq (setq qualifiers (first qualifiers)) :BEFORE) - (push f before)) - ((eq qualifiers :AFTER) (push f after)) - ((eq qualifiers :AROUND) (push f around)) - (t (error-qualifier m qualifiers))))) + (let* ((qualifiers (method-qualifiers m)) + (f (method-function m))) + (cond ((null qualifiers) (push f primary)) + ((rest qualifiers) (error-qualifier m qualifiers)) + ((eq (setq qualifiers (first qualifiers)) :BEFORE) + (push f before)) + ((eq qualifiers :AFTER) (push f after)) + ((eq qualifiers :AROUND) (push f around)) + (t (error-qualifier m qualifiers))))) ;; When there are no primary methods, an error is to be signaled, ;; and we need not care about :AROUND, :AFTER or :BEFORE methods. (when (null primary) - (return-from standard-compute-effective-method - #'(lambda (&rest args) - (apply 'no-primary-method gf args)))) + (return-from standard-compute-effective-method + #'(lambda (&rest args) + (apply 'no-primary-method gf args)))) ;; PRIMARY, BEFORE and AROUND are reversed because they have to ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER ;; may remain as it is because it is least-specific-order. (setf primary (nreverse primary) - before (nreverse before)) + before (nreverse before)) (if around - (let ((main (if (or before after) - (list - (standard-main-effective-method before primary after)) - primary))) - (setf around (nreverse around)) - (combine-method-functions (first around) - (nconc (rest around) main))) - (if (or before after) - (standard-main-effective-method before primary after) - (combine-method-functions (first primary) (rest primary)))) + (let ((main (if (or before after) + (list + (standard-main-effective-method before primary after)) + primary))) + (setf around (nreverse around)) + (combine-method-functions (first around) + (nconc (rest around) main))) + (if (or before after) + (standard-main-effective-method before primary after) + (combine-method-functions (first primary) (rest primary)))) ))) ;; ---------------------------------------------------------------------- ;; DEFINE-METHOD-COMBINATION ;; ;; METHOD-COMBINATION objects are just a list -;; (name arg*) +;; (name arg*) ;; where NAME is the name of the method combination type defined with ;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments. ;; ;; For each method combination type there is an associated function, ;; and the list of all known method combination types is kept in ;; *METHOD-COMBINATIONS* in the form of property list: -;; (mc-type-name1 function1 mc-type-name2 function2 ....) +;; (mc-type-name1 function1 mc-type-name2 function2 ....) ;; ;; FUNCTIONn is the function associated to a method combination. It ;; is of type (FUNCTION (generic-function method-list) FUNCTION), @@ -193,7 +193,7 @@ (defun search-method-combination (name) (mp:with-lock (*method-combinations-lock*) (or (gethash name *method-combinations*) - (error "~A does not name a method combination" name)))) + (error "~A does not name a method combination" name)))) (defun install-method-combination (name function) (mp:with-lock (*method-combinations-lock*) @@ -210,99 +210,99 @@ (defun find-method-combination (gf method-combination-type-name method-combination-options) (make-method-combination method-combination-type-name - (search-method-combination method-combination-type-name) - method-combination-options - )) + (search-method-combination method-combination-type-name) + method-combination-options + )) (defun define-simple-method-combination (name &key documentation - identity-with-one-argument - (operator name)) + identity-with-one-argument + (operator name)) `(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST)) ((around (:AROUND)) (principal (,name) :REQUIRED t)) ,documentation (let ((main-effective-method - `(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL)) - (if (eql order :MOST-SPECIFIC-LAST) - (reverse principal) - principal))))) + `(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL)) + (if (eql order :MOST-SPECIFIC-LAST) + (reverse principal) + principal))))) (cond (around - `(call-method ,(first around) - (,@(rest around) (make-method ,main-effective-method)))) - (,(if identity-with-one-argument - '(rest principal) - t) - main-effective-method) - (t (second main-effective-method)))))) + `(call-method ,(first around) + (,@(rest around) (make-method ,main-effective-method)))) + (,(if identity-with-one-argument + '(rest principal) + t) + main-effective-method) + (t (second main-effective-method)))))) (defun define-complex-method-combination (form) (declare (si::c-local)) (flet ((syntax-error () - (error "~S is not a valid DEFINE-METHOD-COMBINATION form" - form))) + (error "~S is not a valid DEFINE-METHOD-COMBINATION form" + form))) (destructuring-bind (name lambda-list method-groups &rest body &aux - (group-names '()) - (group-checks '()) - (group-after '()) - (generic-function '.generic-function.) - (method-arguments '())) - form + (group-names '()) + (group-checks '()) + (group-after '()) + (generic-function '.generic-function.) + (method-arguments '())) + form (unless (symbolp name) (syntax-error)) (let ((x (first body))) - (when (and (consp x) (eql (first x) :ARGUMENTS)) - (error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION."))) + (when (and (consp x) (eql (first x) :ARGUMENTS)) + (error "Option :ARGUMENTS is not supported in DEFINE-METHOD-COMBINATION."))) (let ((x (first body))) - (when (and (consp x) (eql (first x) :GENERIC-FUNCTION)) - (setf body (rest body)) - (unless (symbolp (setf generic-function (second x))) - (syntax-error)))) + (when (and (consp x) (eql (first x) :GENERIC-FUNCTION)) + (setf body (rest body)) + (unless (symbolp (setf generic-function (second x))) + (syntax-error)))) (dolist (group method-groups) - (destructuring-bind (group-name predicate &key description - (order :most-specific-first) (required nil)) - group - (if (symbolp group-name) - (push group-name group-names) - (syntax-error)) - (let ((condition - (cond ((eql predicate '*) 'T) - ((and predicate (symbolp predicate)) + (destructuring-bind (group-name predicate &key description + (order :most-specific-first) (required nil)) + group + (if (symbolp group-name) + (push group-name group-names) + (syntax-error)) + (let ((condition + (cond ((eql predicate '*) 'T) + ((and predicate (symbolp predicate)) `(,predicate .METHOD-QUALIFIERS.)) - ((and (listp predicate) - (let* ((q (last predicate 0)) - (p (copy-list (butlast predicate 0)))) - (when (every #'symbolp p) - (if (eql q '*) - `(every #'equal ',p .METHOD-QUALIFIERS.) - `(equal ',p .METHOD-QUALIFIERS.)))))) - (t (syntax-error))))) - (push `(,condition (push .METHOD. ,group-name)) group-checks)) - (when required - (push `(unless ,group-name - (error "Method combination: ~S. No methods ~ - in required group ~S." ,name ,group-name)) - group-after)) - (case order - (:most-specific-first - (push `(setf ,group-name (nreverse ,group-name)) group-after)) - (:most-specific-last) - (otherwise + ((and (listp predicate) + (let* ((q (last predicate 0)) + (p (copy-list (butlast predicate 0)))) + (when (every #'symbolp p) + (if (eql q '*) + `(every #'equal ',p .METHOD-QUALIFIERS.) + `(equal ',p .METHOD-QUALIFIERS.)))))) + (t (syntax-error))))) + (push `(,condition (push .METHOD. ,group-name)) group-checks)) + (when required + (push `(unless ,group-name + (error "Method combination: ~S. No methods ~ + in required group ~S." ,name ,group-name)) + group-after)) + (case order + (:most-specific-first + (push `(setf ,group-name (nreverse ,group-name)) group-after)) + (:most-specific-last) + (otherwise (let ((order-var (gensym))) (setf group-names (append group-names (list (list order-var order))) group-after (list* `(when (eq ,order-var :most-specific-first) (setf ,group-name (nreverse ,group-name))) group-after))))))) `(install-method-combination ',name - (ext::lambda-block ,name (,generic-function .methods-list. ,@lambda-list) - (let (,@group-names) - (dolist (.method. .methods-list.) - (let ((.method-qualifiers. (method-qualifiers .method.))) - (cond ,@(nreverse group-checks) - (t (invalid-method-error .method. - "Method qualifiers ~S are not allowed in the method~ - combination ~S." .method-qualifiers. ,name))))) - ,@group-after - (effective-method-function (progn ,@body) t)))) + (ext::lambda-block ,name (,generic-function .methods-list. ,@lambda-list) + (let (,@group-names) + (dolist (.method. .methods-list.) + (let ((.method-qualifiers. (method-qualifiers .method.))) + (cond ,@(nreverse group-checks) + (t (invalid-method-error .method. + "Method qualifiers ~S are not allowed in the method~ + combination ~S." .method-qualifiers. ,name))))) + ,@group-after + (effective-method-function (progn ,@body) t)))) ))) (defmacro define-method-combination (name &body body) @@ -313,12 +313,12 @@ (defun method-combination-error (format-control &rest args) ;; FIXME! We should emit a more detailed error! (error "Method-combination error:~%~S" - (apply #'format nil format-control args))) + (apply #'format nil format-control args))) (defun invalid-method-error (method format-control &rest args) (error "Invalid method error for ~A~%~S" - method - (apply #'format nil format-control args))) + method + (apply #'format nil format-control args))) ;;; ---------------------------------------------------------------------- ;;; COMPUTE-EFFECTIVE-METHOD @@ -333,14 +333,14 @@ (defun std-compute-effective-method (gf method-combination applicable-methods) (declare (type method-combination method-combination) - (type generic-function gf) - (optimize speed (safety 0))) + (type generic-function gf) + (optimize speed (safety 0))) (with-early-accessors (+method-combination-slots+) (let* ((compiler (method-combination-compiler method-combination)) - (options (method-combination-options method-combination))) + (options (method-combination-options method-combination))) (if options - (apply compiler gf applicable-methods options) - (funcall compiler gf applicable-methods))))) + (apply compiler gf applicable-methods options) + (funcall compiler gf applicable-methods))))) (defun compute-effective-method-function (gf method-combination applicable-methods) ;; Cannot be inlined because it will be a method @@ -348,29 +348,29 @@ (let ((form (compute-effective-method gf method-combination applicable-methods))) (let ((aux form) f) (if (and (listp aux) - (eq (pop aux) 'funcall) - (functionp (setf f (pop aux))) - (eq (pop aux) '.combined-method-args.) - (eq (pop aux) '*next-methods*)) - f - (effective-method-function form t))))) + (eq (pop aux) 'funcall) + (functionp (setf f (pop aux))) + (eq (pop aux) '.combined-method-args.) + (eq (pop aux) '*next-methods*)) + f + (effective-method-function form t))))) (defun compute-effective-method (gf method-combination applicable-methods) `(funcall ,(std-compute-effective-method gf method-combination applicable-methods) - .combined-method-args. *next-methods*)) + .combined-method-args. *next-methods*)) ;; ;; These method combinations are bytecompiled, for simplicity. ;; (install-method-combination 'standard 'standard-compute-effective-method) (eval '(progn - (define-method-combination progn :identity-with-one-argument t) - (define-method-combination and :identity-with-one-argument t) - (define-method-combination max :identity-with-one-argument t) - (define-method-combination + :identity-with-one-argument t) - (define-method-combination nconc :identity-with-one-argument t) - (define-method-combination append :identity-with-one-argument nil) - (define-method-combination list :identity-with-one-argument nil) - (define-method-combination min :identity-with-one-argument t) - (define-method-combination or :identity-with-one-argument t))) + (define-method-combination progn :identity-with-one-argument t) + (define-method-combination and :identity-with-one-argument t) + (define-method-combination max :identity-with-one-argument t) + (define-method-combination + :identity-with-one-argument t) + (define-method-combination nconc :identity-with-one-argument t) + (define-method-combination append :identity-with-one-argument nil) + (define-method-combination list :identity-with-one-argument nil) + (define-method-combination min :identity-with-one-argument t) + (define-method-combination or :identity-with-one-argument t))) diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 5bbbae5ce..a8ada19dc 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -42,20 +42,20 @@ ;;; do we need copy-list if *restart-clusters* has only one element? Beppe (defun compute-restarts (&optional condition) (let* ((assoc-restart ()) - (other ()) - (output ())) + (other ()) + (output ())) (when condition (dolist (i *condition-restarts*) - (if (eq (first i) condition) - (setq assoc-restart (append (rest i) assoc-restart)) - (setq other (append (rest i) other))))) + (if (eq (first i) condition) + (setq assoc-restart (append (rest i) assoc-restart)) + (setq other (append (rest i) other))))) (dolist (restart-cluster *restart-clusters*) (dolist (restart restart-cluster) - (when (and (or (not condition) - (member restart assoc-restart) - (not (member restart other))) - (funcall (restart-test-function restart) condition)) - (push restart output)))) + (when (and (or (not condition) + (member restart assoc-restart) + (not (member restart other))) + (funcall (restart-test-function restart) condition)) + (push restart output)))) (nreverse output))) (defun restart-print (restart stream depth) @@ -76,38 +76,38 @@ (declare (si::c-local)) (let ((fn (restart-report-function restart))) (if fn - (funcall fn stream) - (format stream "~s" (or (restart-name restart) restart))))) + (funcall fn stream) + (format stream "~s" (or (restart-name restart) restart))))) (defun bind-simple-restarts (tag names) (flet ((simple-restart-function (tag code) - #'(lambda (&rest args) (throw tag (values code args))))) + #'(lambda (&rest args) (throw tag (values code args))))) (cons (loop for i from 1 - for n in (if (atom names) (list names) names) - for f = (simple-restart-function tag i) - collect (let ((v i)) - (make-restart :name n - :function f))) - *restart-clusters*))) + for n in (if (atom names) (list names) names) + for f = (simple-restart-function tag i) + collect (let ((v i)) + (make-restart :name n + :function f))) + *restart-clusters*))) (defun bind-simple-handlers (tag names) (flet ((simple-handler-function (tag code) - #'(lambda (c) (throw tag (values code c))))) + #'(lambda (c) (throw tag (values code c))))) (cons (loop for i from 1 - for n in (if (atom names) (list names) names) - for f = (simple-handler-function tag i) - collect (cons n f)) - *handler-clusters*))) + for n in (if (atom names) (list names) names) + for f = (simple-handler-function tag i) + collect (cons n f)) + *handler-clusters*))) (defmacro restart-bind (bindings &body forms) `(let ((*restart-clusters* - (cons (list ,@(mapcar #'(lambda (binding) - `(make-restart - :NAME ',(car binding) - :FUNCTION ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) + (cons (list ,@(mapcar #'(lambda (binding) + `(make-restart + :NAME ',(car binding) + :FUNCTION ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) ,@forms)) (defun find-restart (name &optional condition) @@ -119,8 +119,8 @@ (declare (si::c-local)) (or (find-restart restart condition) (signal-simple-error 'control-error nil - "Restart ~S is not active." - (list restart)))) + "Restart ~S is not active." + (list restart)))) (defun invoke-restart (restart &rest values) (let ((real-restart (find-restart-never-fail restart))) @@ -129,113 +129,113 @@ (defun invoke-restart-interactively (restart) (let ((real-restart (find-restart-never-fail restart))) (apply (restart-function real-restart) - (let ((interactive-function - (restart-interactive-function real-restart))) - (if interactive-function - (funcall interactive-function) - '()))))) + (let ((interactive-function + (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) + '()))))) (defmacro restart-case (expression &body clauses &environment env) (flet ((transform-keywords (&key report interactive test) - (let ((keywords '())) - (when test - (setq keywords (list :TEST-FUNCTION `#',test))) - (when interactive - (setq keywords (list :INTERACTIVE-FUNCTION - `#',interactive))) - (when report - (setq keywords (list* :REPORT-FUNCTION - (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - keywords))) - keywords))) + (let ((keywords '())) + (when test + (setq keywords (list :TEST-FUNCTION `#',test))) + (when interactive + (setq keywords (list :INTERACTIVE-FUNCTION + `#',interactive))) + (when report + (setq keywords (list* :REPORT-FUNCTION + (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + keywords))) + keywords))) (let*((block-tag (gensym)) - (temp-var (gensym)) - (data (mapcar #'(lambda (clause) - (let (keywords (forms (cddr clause))) - (do () - ((null forms)) - (if (keywordp (car forms)) - (setq keywords (list* (car forms) - (cadr forms) - keywords) - forms (cddr forms)) - (return))) - (list (car clause) ;Name=0 - (gensym) ;Tag=1 - (apply #'transform-keywords ;Keywords=2 - keywords) - (cadr clause) ;BVL=3 - forms))) ;Body=4 - clauses))) + (temp-var (gensym)) + (data (mapcar #'(lambda (clause) + (let (keywords (forms (cddr clause))) + (do () + ((null forms)) + (if (keywordp (car forms)) + (setq keywords (list* (car forms) + (cadr forms) + keywords) + forms (cddr forms)) + (return))) + (list (car clause) ;Name=0 + (gensym) ;Tag=1 + (apply #'transform-keywords ;Keywords=2 + keywords) + (cadr clause) ;BVL=3 + forms))) ;Body=4 + clauses))) (let ((expression2 (macroexpand expression env))) - (when (consp expression2) - (let* ((condition-form nil) - (condition-var (gensym)) - (name (first expression2))) - (case name - (SIGNAL - (setq condition-form (second expression2))) - (ERROR - (setq condition-form `(coerce-to-condition ,(second expression2) - (list ,@(cddr expression2)) - 'SIMPLE-ERROR 'ERROR))) - (CERROR - (setq condition-form `(coerce-to-condition ,(third expression2) - (list ,@(cdddr expression2)) - 'SIMPLE-ERROR 'CERROR))) - (WARN - (setq condition-form `(coerce-to-condition ,(second expression2) - (list ,@(cddr expression2)) - 'SIMPLE-WARNING 'WARN)))) - (when condition-form - (setq expression - `(let ((,condition-var ,condition-form)) - (with-condition-restarts ,condition-var - (first *restart-clusters*) - ,(if (eq name 'CERROR) - `(cerror ,(second expression2) ,condition-var) - (list name condition-var))))) - )))) + (when (consp expression2) + (let* ((condition-form nil) + (condition-var (gensym)) + (name (first expression2))) + (case name + (SIGNAL + (setq condition-form (second expression2))) + (ERROR + (setq condition-form `(coerce-to-condition ,(second expression2) + (list ,@(cddr expression2)) + 'SIMPLE-ERROR 'ERROR))) + (CERROR + (setq condition-form `(coerce-to-condition ,(third expression2) + (list ,@(cdddr expression2)) + 'SIMPLE-ERROR 'CERROR))) + (WARN + (setq condition-form `(coerce-to-condition ,(second expression2) + (list ,@(cddr expression2)) + 'SIMPLE-WARNING 'WARN)))) + (when condition-form + (setq expression + `(let ((,condition-var ,condition-form)) + (with-condition-restarts ,condition-var + (first *restart-clusters*) + ,(if (eq name 'CERROR) + `(cerror ,(second expression2) ,condition-var) + (list name condition-var))))) + )))) `(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 ,expression)) - ,@(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 ,expression)) + ,@(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 with-simple-restart ((restart-name format-control - &rest format-arguments) - &body forms) + &rest format-arguments) + &body forms) `(restart-case (progn ,@forms) (,restart-name () :REPORT (lambda (stream) - (format stream ,format-control ,@format-arguments)) + (format stream ,format-control ,@format-arguments)) (values nil t)))) (defmacro with-condition-restarts (condition restarts &body forms) `(let ((*condition-restarts* (cons (cons ,condition ,restarts) - *condition-restarts*))) + *condition-restarts*))) ,@forms)) @@ -249,12 +249,12 @@ (if *print-escape* (call-next-method) (let ((reporter (slot-value c 'report-function))) - (cond ((stringp reporter) - (write-string reporter stream)) - ((null reporter) - (call-next-method)) - (t - (funcall reporter c stream)))))) + (cond ((stringp reporter) + (write-string reporter stream)) + ((null reporter) + (call-next-method)) + (t + (funcall reporter c stream)))))) (defmacro define-condition (name parent-list slot-specs &rest options) ;; CAUTION: ANSI states the equivalence between :REPORT and a method. @@ -263,16 +263,16 @@ (let* ((class-options nil)) (dolist (option options) (case (car option) - ((:DEFAULT-INITARGS :DOCUMENTATION) - (push option class-options)) - (:REPORT - (let ((report-function (cadr option))) - (push `(report-function :initform ,(if (symbolp report-function) - (list 'quote report-function) - report-function)) - slot-specs))) - (otherwise (cerror "Ignore this DEFINE-CONDITION option." - "Invalid DEFINE-CONDITION option: ~S" option)))) + ((:DEFAULT-INITARGS :DOCUMENTATION) + (push option class-options)) + (:REPORT + (let ((report-function (cadr option))) + (push `(report-function :initform ,(if (symbolp report-function) + (list 'quote report-function) + report-function)) + slot-specs))) + (otherwise (cerror "Ignore this DEFINE-CONDITION option." + "Invalid DEFINE-CONDITION option: ~S" option)))) `(PROGN (DEFCLASS ,name ,(or parent-list '(CONDITION)) ,slot-specs ,@class-options) ',NAME))) @@ -283,18 +283,18 @@ (if (subtypep class type) (list class) (loop for c in (clos::class-direct-subclasses class) - nconc (find-subclasses-of-type type c)))) + nconc (find-subclasses-of-type type c)))) (defun make-condition (type &rest slot-initializations) (let ((class (or (and (symbolp type) (find-class type nil)) - (first (last (sort (find-subclasses-of-type type (find-class 'condition)) - #'si::subclassp)))))) + (first (last (sort (find-subclasses-of-type type (find-class 'condition)) + #'si::subclassp)))))) (unless class (error 'SIMPLE-TYPE-ERROR - :DATUM type - :EXPECTED-TYPE 'CONDITION - :FORMAT-CONTROL "Not a condition type: ~S" - :FORMAT-ARGUMENTS (list type))) + :DATUM type + :EXPECTED-TYPE 'CONDITION + :FORMAT-CONTROL "Not a condition type: ~S" + :FORMAT-ARGUMENTS (list type))) (apply #'make-instance class slot-initializations))) #| For the moment, do not redefine these. Beppe. @@ -306,14 +306,14 @@ ((null c) (nreverse l)) (let ((keys (caar c))) (cond ((atom keys) - (cond ((null keys)) - ((member keys '(OTHERWISE T)) - (error "OTHERWISE is not allowed in ~S expressions." - macro-name)) - (t (push keys l)))) - (list-is-atom-p - (push keys l)) - (t (setq l (append keys l))))))) + (cond ((null keys)) + ((member keys '(OTHERWISE T)) + (error "OTHERWISE is not allowed in ~S expressions." + macro-name)) + (t (push keys l)))) + (list-is-atom-p + (push keys l)) + (t (setq l (append keys l))))))) );nehw-lave @@ -323,32 +323,32 @@ ,@cases (otherwise (error 'CASE-FAILURE :name 'ECASE - :datum ,keyform - :expected-type '(MEMBER ,@keys) - :possibilities ',keys)))))) + :datum ,keyform + :expected-type '(MEMBER ,@keys) + :possibilities ',keys)))))) (defmacro ccase (keyplace &rest cases) (let ((keys (accumulate-cases 'CCASE cases nil)) - (tag1 (gensym)) - (tag2 (gensym))) + (tag1 (gensym)) + (tag2 (gensym))) `(block ,tag1 (tagbody ,tag2 - (return-from ,tag1 - (case ,keyplace - ,@cases - (otherwise - (restart-case (error 'CASE-FAILURE - :name 'CCASE - :datum ,keyplace - :expected-type '(MEMBER ,@keys) - :possibilities ',keys) - (store-value (value) - :report (lambda (stream) - (format stream "Supply a new value of ~S." - ',keyplace)) - :interactive read-evaluated-form - (setf ,keyplace value) - (go ,tag2)))))))))) + (return-from ,tag1 + (case ,keyplace + ,@cases + (otherwise + (restart-case (error 'CASE-FAILURE + :name 'CCASE + :datum ,keyplace + :expected-type '(MEMBER ,@keys) + :possibilities ',keys) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value of ~S." + ',keyplace)) + :interactive read-evaluated-form + (setf ,keyplace value) + (go ,tag2)))))))))) @@ -358,32 +358,32 @@ ,@cases (otherwise (error 'CASE-FAILURE :name 'ETYPECASE - :datum ,keyform - :expected-type '(OR ,@types) - :possibilities ',types))))) + :datum ,keyform + :expected-type '(OR ,@types) + :possibilities ',types))))) (defmacro ctypecase (keyplace &rest cases) (let ((types (accumulate-cases 'CTYPECASE cases t)) - (tag1 (gensym)) - (tag2 (gensym))) + (tag1 (gensym)) + (tag2 (gensym))) `(block ,tag1 (tagbody ,tag2 - (return-from ,tag1 - (typecase ,keyplace - ,@cases - (otherwise - (restart-case (error 'CASE-FAILURE - :name 'CTYPECASE - :datum ,keyplace - :expected-type '(OR ,@types) - :possibilities ',types) - (store-value (value) - :REPORT (lambda (stream) - (format stream "Supply a new value of ~S." - ',keyplace)) - :INTERACTIVE read-evaluated-form - (setf ,keyplace value) - (go ,tag2)))))))))) + (return-from ,tag1 + (typecase ,keyplace + ,@cases + (otherwise + (restart-case (error 'CASE-FAILURE + :name 'CTYPECASE + :datum ,keyplace + :expected-type '(OR ,@types) + :possibilities ',types) + (store-value (value) + :REPORT (lambda (stream) + (format stream "Supply a new value of ~S." + ',keyplace)) + :INTERACTIVE read-evaluated-form + (setf ,keyplace value) + (go ,tag2)))))))))) |# @@ -394,24 +394,24 @@ (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) (error "Ill-formed handler bindings.")) `(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*))) ,@forms)) (defun signal (datum &rest arguments) (let* ((condition - (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) - (*handler-clusters* *handler-clusters*)) + (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) + (*handler-clusters* *handler-clusters*)) (if (typep condition *break-on-signals*) - (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." - condition)) + (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." + condition)) (loop (unless *handler-clusters* (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)) @@ -423,27 +423,27 @@ (defun coerce-to-condition (datum arguments default-type function-name) (cond ((typep datum 'CONDITION) - (when arguments - (cerror "Ignore the additional arguments." - 'SIMPLE-TYPE-ERROR - :DATUM arguments - :EXPECTED-TYPE 'NULL - :FORMAT-CONTROL "You may not supply additional arguments ~ - when giving ~S to ~S." - :FORMAT-ARGUMENTS (list datum function-name))) - datum) + (when arguments + (cerror "Ignore the additional arguments." + 'SIMPLE-TYPE-ERROR + :DATUM arguments + :EXPECTED-TYPE 'NULL + :FORMAT-CONTROL "You may not supply additional arguments ~ + when giving ~S to ~S." + :FORMAT-ARGUMENTS (list datum function-name))) + datum) ((symbolp datum) ;roughly, (subtypep datum 'CONDITION) (apply #'make-condition datum arguments)) ((or (stringp datum) (functionp datum)) - (make-condition default-type + (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 function-name datum))))) + :DATUM datum + :EXPECTED-TYPE '(OR SYMBOL STRING) + :FORMAT-CONTROL "Bad argument to ~S: ~S" + :FORMAT-ARGUMENTS (list function-name datum))))) (defun break (&optional (format-control "Break") &rest format-arguments) "Enters a break loop. The execution of the program can be resumed by typing @@ -465,12 +465,12 @@ Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. Enters a break level if the value of *BREAK-ON-WARNINGS* is non-NIL. Otherwise, returns with NIL." (let ((condition - (coerce-to-condition datum arguments 'SIMPLE-WARNING 'WARN))) + (coerce-to-condition datum arguments 'SIMPLE-WARNING 'WARN))) (check-type condition warning "a warning condition") (restart-case (signal condition) (muffle-warning () - :REPORT "Skip warning." - (return-from warn nil))) + :REPORT "Skip warning." + (return-from warn nil))) (format *error-output* "~&;;; Warning: ~A~%" condition) nil)) @@ -492,13 +492,13 @@ returns with NIL." (define-condition simple-condition () ((format-control :INITARG :FORMAT-CONTROL :INITFORM "" - :ACCESSOR simple-condition-format-control) + :ACCESSOR simple-condition-format-control) (format-arguments :INITARG :FORMAT-ARGUMENTS :INITFORM NIL - :ACCESSOR simple-condition-format-arguments)) + :ACCESSOR simple-condition-format-arguments)) (:REPORT (lambda (condition stream) (format stream "~?" (simple-condition-format-control condition) - (simple-condition-format-arguments condition))))) + (simple-condition-format-arguments condition))))) (define-condition simple-warning (simple-condition warning) ()) @@ -520,13 +520,13 @@ returns with NIL." (:REPORT (lambda (condition stream) (let* ((type (ext::stack-overflow-type condition)) - (size (ext::stack-overflow-size condition))) + (size (ext::stack-overflow-size condition))) (if size - (format stream "~A overflow at size ~D. Stack can probably be resized." - type size) - (format stream "~A stack overflow. Stack cannot grow any further. Either exit + (format stream "~A overflow at size ~D. Stack can probably be resized." + type size) + (format stream "~A stack overflow. Stack cannot grow any further. Either exit or return to an outer frame, undoing all the function calls so far." - type)))))) + type)))))) (define-condition ext:storage-exhausted (storage-condition) () (:REPORT "Memory limit reached. Please jump to an outer pointer, quit program and enlarge the @@ -551,8 +551,8 @@ memory limits before executing the program again.")) (:REPORT (lambda (condition stream) (format stream "~S is not of type ~S." - (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) ()) @@ -562,9 +562,9 @@ memory limits before executing the program again.")) (:REPORT (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 program-error (error) ()) @@ -576,17 +576,17 @@ memory limits before executing the program again.")) (define-condition end-of-file (stream-error) () (:REPORT (lambda (condition stream) - (format stream "Unexpected end of file on ~S." - (stream-error-stream condition))))) + (format stream "Unexpected end of file on ~S." + (stream-error-stream condition))))) (define-condition file-error (error) ((pathname :INITARG :PATHNAME :READER file-error-pathname)) (:REPORT (lambda (condition stream) - (format stream "Filesystem error with pathname ~S.~%Either + (format stream "Filesystem error with pathname ~S.~%Either 1) the file does not exist, or 2) we are not allowed to access the file, or 3) the pathname points to a broken symbolic link." - (file-error-pathname condition))))) + (file-error-pathname condition))))) (define-condition package-error (error) ((package :INITARG :PACKAGE :READER package-error-package))) @@ -597,21 +597,21 @@ memory limits before executing the program again.")) (define-condition unbound-variable (cell-error) () (:REPORT (lambda (condition stream) - (format stream "The variable ~S is unbound." - (cell-error-name condition))))) + (format stream "The variable ~S is unbound." + (cell-error-name condition))))) (define-condition unbound-slot (cell-error) ((instance :INITARG :INSTANCE :READER unbound-slot-instance)) (:REPORT (lambda (condition stream) - (format stream "The slot ~S in the object ~S is unbound." - (cell-error-name condition) - (unbound-slot-instance condition))))) + (format stream "The slot ~S in the object ~S is unbound." + (cell-error-name condition) + (unbound-slot-instance condition))))) (define-condition undefined-function (cell-error) () (:REPORT (lambda (condition stream) - (format stream "The function ~S is undefined." - (cell-error-name condition))))) + (format stream "The function ~S is undefined." + (cell-error-name condition))))) (define-condition arithmetic-error (error) ((operation :INITARG :OPERATION :READER arithmetic-error-operation) @@ -633,8 +633,8 @@ memory limits before executing the program again.")) (define-condition print-not-readable (error) ((object :INITARG :OBJECT :READER print-not-readable-object)) (:REPORT (lambda (condition stream) - (format stream "Cannot print object ~A readably." - (print-not-readable-object condition))))) + (format stream "Cannot print object ~A readably." + (print-not-readable-object condition))))) (define-condition parse-error (error) ()) @@ -644,23 +644,23 @@ memory limits before executing the program again.")) ((format-control :initarg :complaint) (format-arguments :initarg :arguments) (control-string :reader format-error-control-string - :initarg :control-string - #+cmu-format :initform - #+cmu-format *default-format-error-control-string*) + :initarg :control-string + #+cmu-format :initform + #+cmu-format *default-format-error-control-string*) (offset :reader format-error-offset :initarg :offset - #+cmu-format :initform - #+cmu-format *default-format-error-offset*) + #+cmu-format :initform + #+cmu-format *default-format-error-offset*) (print-banner :reader format-error-print-banner :initarg :print-banner - :initform t)) + :initform t)) (:report (lambda (condition stream) - (cl:format stream - "~:[~;Error in format: ~]~ - ~?~@[~% ~A~% ~V@T^~]" - (format-error-print-banner condition) - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - (format-error-control-string condition) - (format-error-offset condition))))) + (cl:format stream + "~:[~;Error in format: ~]~ + ~?~@[~% ~A~% ~V@T^~]" + (format-error-print-banner condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + (format-error-control-string condition) + (format-error-offset condition))))) (define-condition ext:interactive-interrupt (serious-condition) () @@ -668,58 +668,58 @@ memory limits before executing the program again.")) (defun signal-simple-error (base-condition continue-message format-control format-args - &rest args) + &rest args) (let ((simple-error-name (intern (concatenate 'string "SIMPLE-" (string base-condition)) - (find-package "SI")))) + (find-package "SI")))) (unless (find-class simple-error-name nil) (eval `(defclass ,simple-error-name (simple-error ,base-condition) ()))) (if continue-message - (apply #'cerror continue-message simple-error-name :format-control format-control - :format-arguments format-args args) - (apply #'error simple-error-name :format-control format-control - :format-arguments format-args args)))) - + (apply #'cerror continue-message simple-error-name :format-control format-control + :format-arguments format-args args) + (apply #'error simple-error-name :format-control format-control + :format-arguments format-args args)))) + (defmacro handler-case (form &rest cases) (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) + (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) (declare (ignorable temp)) - ,@(if (caddr annotated-case) - `((setq ,var temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag ,form)) - ,@(mapcan #'(lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from ,tag - ,(if (caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body) - ;; We must allow declarations! - `(locally ,@body)))))) - annotated-cases)))))))) + ,@(if (caddr annotated-case) + `((setq ,var temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag ,form)) + ,@(mapcan #'(lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from ,tag + ,(if (caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body) + ;; We must allow declarations! + `(locally ,@body)))))) + annotated-cases)))))))) (defmacro ignore-errors (&rest forms) `(handler-case (progn ,@forms) @@ -749,13 +749,13 @@ memory limits before executing the program again.")) (format stream "Retry assertion") (if names (format stream " with new value~P for ~{~S~^, ~}." - (length names) names) + (length names) names) (format stream "."))) (defun assert-prompt (name value) (declare (si::c-local)) (if (y-or-n-p "The old value of ~S is ~S.~ - ~%Do you want to supply a new value? " + ~%Do you want to supply a new value? " name value) (flet ((read-it () (eval (read *query-io*)))) (format *query-io* "~&Type a form to be evaluated:~%") @@ -768,10 +768,10 @@ memory limits before executing the program again.")) &rest arguments) (unless arguments (setf arguments (list 'SIMPLE-TYPE-ERROR - :DATUM test-form - :EXPECTED-TYPE nil ; This needs some work in revision - :FORMAT-CONTROL "The assertion ~S failed" - :FORMAT-ARGUMENTS (list test-form)))) + :DATUM test-form + :EXPECTED-TYPE nil ; This needs some work in revision + :FORMAT-CONTROL "The assertion ~S failed" + :FORMAT-ARGUMENTS (list test-form)))) (restart-case (error (si::coerce-to-condition (first arguments) (rest arguments) 'simple-error @@ -779,9 +779,9 @@ memory limits before executing the program again.")) (continue () :REPORT (lambda (stream) (assert-report place-names stream)) (return-from assert-failure - (values-list (loop for place-name in place-names - for value in values - collect (assert-prompt place-name value))))))) + (values-list (loop for place-name in place-names + for value in values + collect (assert-prompt place-name value))))))) ;;; ---------------------------------------------------------------------- ;;; ECL's interface to the toplevel and debugger @@ -800,36 +800,36 @@ that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the format strings of the error message. ARGS are the arguments to the format strings." (declare (inline apply) ;; So as not to get bogus frames in debugger - #-ecl-min + #-ecl-min (c::policy-debug-ihs-frame)) (let ((condition (coerce-to-condition datum args 'simple-error 'error))) (cond ((eq t continue-string) ; from CEerror; mostly allocation errors (with-simple-restart (ignore "Ignore the error, and try the operation again") - (signal condition) - (invoke-debugger condition))) + (signal condition) + (invoke-debugger condition))) ((stringp continue-string) (with-simple-restart - (continue "~A" (format nil "~?" continue-string args)) - (signal condition) - (invoke-debugger condition))) + (continue "~A" (format nil "~?" continue-string args)) + (signal condition) + (invoke-debugger condition))) ((and continue-string (symbolp continue-string)) ; from CEerror (with-simple-restart (accept "Accept the error, returning NIL") - (multiple-value-bind (rv used-restart) - (with-simple-restart (ignore "Ignore the error, and try the operation again") - (multiple-value-bind (rv used-restart) - (with-simple-restart (continue "Continue, using ~S" continue-string) - (signal condition) - (invoke-debugger condition)) + (multiple-value-bind (rv used-restart) + (with-simple-restart (ignore "Ignore the error, and try the operation again") + (multiple-value-bind (rv used-restart) + (with-simple-restart (continue "Continue, using ~S" continue-string) + (signal condition) + (invoke-debugger condition)) - (if used-restart continue-string rv))) - (if used-restart t rv)))) + (if used-restart continue-string rv))) + (if used-restart t rv)))) (t - (progn - (signal condition) - (invoke-debugger condition)))))) + (progn + (signal condition) + (invoke-debugger condition)))))) (defun sys::tpl-continue-command (&rest any) (apply #'invoke-restart 'continue any)) diff --git a/src/clos/cpl.lsp b/src/clos/cpl.lsp index 850779466..0dc1a393b 100644 --- a/src/clos/cpl.lsp +++ b/src/clos/cpl.lsp @@ -23,112 +23,112 @@ #+(or) (defun compute-clos-class-precedence-list (new-class superclasses) (labels ((pair-list (l) - (if (or (null l) (endp (cdr l))) - nil - (cons (cons (first l) (second l)) - (pair-list (rest l))))) - (walk-supers (parent superclasses class-list precedence-alist) - (let ((new-alist (pair-list (if parent - (list* parent superclasses) - superclasses)))) - (setf precedence-alist (nconc new-alist precedence-alist) - class-list (union superclasses class-list))) - (dolist (c superclasses) - (multiple-value-setq (class-list precedence-alist) - (walk-supers c (class-direct-superclasses c) class-list precedence-alist))) - (values class-list precedence-alist)) - (cycle-error (new-class) - (error "A cycle has been detected in the class precedence list for ~A." - (class-name new-class))) - (free-elements (class-list precedence-alist) - (set-difference class-list - (delete-duplicates (mapcar #'cdr precedence-alist)))) - (next-element (free-list cpl) - (if (or (null cpl) (endp free-list) (endp (rest free-list))) - (first free-list) - (dolist (i cpl nil) - (dolist (j (class-direct-superclasses i)) - (when (member j free-list) - (return-from next-element j))))))) + (if (or (null l) (endp (cdr l))) + nil + (cons (cons (first l) (second l)) + (pair-list (rest l))))) + (walk-supers (parent superclasses class-list precedence-alist) + (let ((new-alist (pair-list (if parent + (list* parent superclasses) + superclasses)))) + (setf precedence-alist (nconc new-alist precedence-alist) + class-list (union superclasses class-list))) + (dolist (c superclasses) + (multiple-value-setq (class-list precedence-alist) + (walk-supers c (class-direct-superclasses c) class-list precedence-alist))) + (values class-list precedence-alist)) + (cycle-error (new-class) + (error "A cycle has been detected in the class precedence list for ~A." + (class-name new-class))) + (free-elements (class-list precedence-alist) + (set-difference class-list + (delete-duplicates (mapcar #'cdr precedence-alist)))) + (next-element (free-list cpl) + (if (or (null cpl) (endp free-list) (endp (rest free-list))) + (first free-list) + (dolist (i cpl nil) + (dolist (j (class-direct-superclasses i)) + (when (member j free-list) + (return-from next-element j))))))) (if (endp (rest superclasses)) (let ((class (first superclasses))) - (list* new-class (class-precedence-list class))) + (list* new-class (class-precedence-list class))) (multiple-value-bind (class-list precedence-alist) - (walk-supers nil superclasses nil nil) - (do ((cpl (list new-class))) - ((null class-list) - (if precedence-alist (cycle-error new-class) (nreverse cpl))) - (let* ((candidates (free-elements class-list precedence-alist)) - (next (next-element candidates cpl))) - (unless next - (cycle-error new-class)) - (setf precedence-alist (delete next precedence-alist :key #'car) - class-list (delete next class-list) - cpl (cons next cpl)))))))) + (walk-supers nil superclasses nil nil) + (do ((cpl (list new-class))) + ((null class-list) + (if precedence-alist (cycle-error new-class) (nreverse cpl))) + (let* ((candidates (free-elements class-list precedence-alist)) + (next (next-element candidates cpl))) + (unless next + (cycle-error new-class)) + (setf precedence-alist (delete next precedence-alist :key #'car) + class-list (delete next class-list) + cpl (cons next cpl)))))))) (defun compute-clos-class-precedence-list (new-class superclasses) (labels ((walk-supers (superclasses) - ;; Creates two lists, one with all the superclasses of a class to be created, - ;; and a second list with lists (c1 c2 c3 ... cn) that represent a partial - ;; ordering of the classes (c1 > c2), (c2 > c3), etc." - (let ((class-list '()) - (precedence-lists (list superclasses))) - (loop (unless superclasses - (return (values class-list precedence-lists))) - (let ((next-class (pop superclasses))) - (unless (member next-class class-list :test 'eql) - (let ((more-classes (slot-value next-class 'direct-superclasses))) - (setf class-list (list* next-class class-list) - precedence-lists (list* (list* next-class more-classes) - precedence-lists) - superclasses (append more-classes superclasses)))))))) - (cycle-error (class) - (error "A cycle has been detected in the class precedence list for ~A." - (class-name class))) - (has-no-precedent (class precedence-lists) - ;; Check if CLASS is not preceded by any other class in the partial order. - (dolist (partial-order precedence-lists t) - (when (member class (rest partial-order) :test 'eql) - (return nil)))) - (free-elements (class-list precedence-lists) - ;; Return classes that are not preceded by anyone - (let ((output '())) - (dolist (class class-list) - (when (has-no-precedent class precedence-lists) - (push class output))) - output)) - (next-element (free-list cpl) - ;; Compute the next element that we will add to the class precedence list. - (if (or (null cpl) (endp free-list) (endp (rest free-list))) - (first free-list) - (dolist (i cpl nil) - (dolist (j (slot-value i 'direct-superclasses)) - (when (member j free-list :test 'eql) - (return-from next-element j)))))) - (delete-class (class precedence-lists) - (do ((l precedence-lists (rest l))) - ((null l) - (delete nil precedence-lists)) - (let ((one-list (first l))) - (when (eq class (first one-list)) - (setf (first l) (rest one-list))))))) + ;; Creates two lists, one with all the superclasses of a class to be created, + ;; and a second list with lists (c1 c2 c3 ... cn) that represent a partial + ;; ordering of the classes (c1 > c2), (c2 > c3), etc." + (let ((class-list '()) + (precedence-lists (list superclasses))) + (loop (unless superclasses + (return (values class-list precedence-lists))) + (let ((next-class (pop superclasses))) + (unless (member next-class class-list :test 'eql) + (let ((more-classes (slot-value next-class 'direct-superclasses))) + (setf class-list (list* next-class class-list) + precedence-lists (list* (list* next-class more-classes) + precedence-lists) + superclasses (append more-classes superclasses)))))))) + (cycle-error (class) + (error "A cycle has been detected in the class precedence list for ~A." + (class-name class))) + (has-no-precedent (class precedence-lists) + ;; Check if CLASS is not preceded by any other class in the partial order. + (dolist (partial-order precedence-lists t) + (when (member class (rest partial-order) :test 'eql) + (return nil)))) + (free-elements (class-list precedence-lists) + ;; Return classes that are not preceded by anyone + (let ((output '())) + (dolist (class class-list) + (when (has-no-precedent class precedence-lists) + (push class output))) + output)) + (next-element (free-list cpl) + ;; Compute the next element that we will add to the class precedence list. + (if (or (null cpl) (endp free-list) (endp (rest free-list))) + (first free-list) + (dolist (i cpl nil) + (dolist (j (slot-value i 'direct-superclasses)) + (when (member j free-list :test 'eql) + (return-from next-element j)))))) + (delete-class (class precedence-lists) + (do ((l precedence-lists (rest l))) + ((null l) + (delete nil precedence-lists)) + (let ((one-list (first l))) + (when (eq class (first one-list)) + (setf (first l) (rest one-list))))))) (cond ((null superclasses) - (list new-class)) - ((endp (rest superclasses)) - (let ((class (first superclasses))) - (list* new-class (slot-value class 'precedence-list)))) - (t - (multiple-value-bind (class-list precedence-lists) - (walk-supers superclasses) - (do ((cpl (list new-class))) - ((null class-list) - (if precedence-lists (cycle-error new-class) (nreverse cpl))) - (let* ((candidates (free-elements class-list precedence-lists)) - (next (next-element candidates cpl))) - (unless next - (cycle-error new-class)) - (setf precedence-lists (delete-class next precedence-lists) - class-list (delete next class-list) - cpl (cons next cpl))))))))) + (list new-class)) + ((endp (rest superclasses)) + (let ((class (first superclasses))) + (list* new-class (slot-value class 'precedence-list)))) + (t + (multiple-value-bind (class-list precedence-lists) + (walk-supers superclasses) + (do ((cpl (list new-class))) + ((null class-list) + (if precedence-lists (cycle-error new-class) (nreverse cpl))) + (let* ((candidates (free-elements class-list precedence-lists)) + (next (next-element candidates cpl))) + (unless next + (cycle-error new-class)) + (setf precedence-lists (delete-class next precedence-lists) + class-list (delete next class-list) + cpl (cons next cpl))))))))) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index bd2d5002d..052ba8529 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -18,37 +18,37 @@ (defun parse-default-initargs (default-initargs) (declare (si::c-local)) (do* ((output-list nil) - (scan default-initargs (cddr scan)) - (already-supplied '())) + (scan default-initargs (cddr scan)) + (already-supplied '())) ((endp scan) `(list ,@(nreverse output-list))) (when (endp (rest scan)) (si::simple-program-error "Wrong number of elements in :DEFAULT-INITARGS option.")) (let ((slot-name (first scan)) - (initform (second scan))) + (initform (second scan))) (if (member slot-name already-supplied) - (si::simple-program-error "~S is duplicated in :DEFAULT-INITARGS form ~S" - slot-name default-initargs) - (push slot-name already-supplied)) + (si::simple-program-error "~S is duplicated in :DEFAULT-INITARGS form ~S" + slot-name default-initargs) + (push slot-name already-supplied)) (push `(list ',slot-name ',initform ,(make-function-initform initform)) - output-list)))) + output-list)))) (defmacro defclass (&whole form &rest args) (unless (>= (length args) 3) (si::simple-program-error "Illegal defclass form: the class name, the superclasses and the slots should always be provided")) (let* ((name (pop args)) - (superclasses (pop args)) - (slots (pop args)) - (options args)) + (superclasses (pop args)) + (slots (pop args)) + (options args)) (unless (and (listp superclasses) (listp slots)) (si::simple-program-error "Illegal defclass form: superclasses and slots should be lists")) (unless (and (symbolp name) (every #'symbolp superclasses)) (si::simple-program-error "Illegal defclass form: superclasses and class name are not valid")) `(eval-when (compile load eval) ,(ext:register-with-pde - form - `(load-defclass ',name ',superclasses - ,(compress-slot-forms slots) - ,(process-class-options options)))))) + form + `(load-defclass ',name ',superclasses + ,(compress-slot-forms slots) + ,(process-class-options options)))))) (defun compress-slot-forms (slot-definitions) (declare (si::c-local)) @@ -56,79 +56,79 @@ ;; may contain object that need to be evaluated. Hence, it cannot be always ;; quoted. (let ((const '()) - (output '()) - (non-const nil)) + (output '()) + (non-const nil)) (dolist (slotd (parse-slots slot-definitions)) (let* ((initfun (getf slotd :initfunction nil)) - (copy (copy-list slotd))) - (remf copy :initfunction) - (cond ((atom initfun) - (push copy const) - (push (ext:maybe-quote copy) output)) - ((eq (first initfun) 'constantly) - (push copy const) - (push (ext:maybe-quote copy) output)) - (t - (push `(list* :initfunction ,initfun ,(ext:maybe-quote copy)) - output) - (setf non-const t))))) + (copy (copy-list slotd))) + (remf copy :initfunction) + (cond ((atom initfun) + (push copy const) + (push (ext:maybe-quote copy) output)) + ((eq (first initfun) 'constantly) + (push copy const) + (push (ext:maybe-quote copy) output)) + (t + (push `(list* :initfunction ,initfun ,(ext:maybe-quote copy)) + output) + (setf non-const t))))) (if non-const - `(list ,@(nreverse output)) - (ext:maybe-quote (nreverse const))))) + `(list ,@(nreverse output)) + (ext:maybe-quote (nreverse const))))) (defun uncompress-slot-forms (slot-definitions) (loop for slotd in slot-definitions for initform = (getf slotd :initform slotd) collect (if (eq initform slotd) - slotd - (if (getf slotd :initfunction) - slotd - (list* :initfunction (constantly (eval initform)) - slotd))))) + slotd + (if (getf slotd :initfunction) + slotd + (list* :initfunction (constantly (eval initform)) + slotd))))) (defun process-class-options (class-args) (let ((options '()) - (processed-options '())) + (processed-options '())) (dolist (option class-args) (let ((option-name (first option)) - option-value) - (if (member option-name processed-options) - (si:simple-program-error - "Option ~s for DEFCLASS specified more than once" - option-name) - (push option-name processed-options)) - (setq option-value - (case option-name - ((:metaclass :documentation) - (ext:maybe-quote (second option))) - (:default-initargs - (setf option-name :direct-default-initargs) - (parse-default-initargs (rest option))) - (otherwise - (ext:maybe-quote (rest option)))) - options (list* (ext:maybe-quote option-name) - option-value options)))) + option-value) + (if (member option-name processed-options) + (si:simple-program-error + "Option ~s for DEFCLASS specified more than once" + option-name) + (push option-name processed-options)) + (setq option-value + (case option-name + ((:metaclass :documentation) + (ext:maybe-quote (second option))) + (:default-initargs + (setf option-name :direct-default-initargs) + (parse-default-initargs (rest option))) + (otherwise + (ext:maybe-quote (rest option)))) + options (list* (ext:maybe-quote option-name) + option-value options)))) (and options `(list ,@options)))) (defun load-defclass (name superclasses slot-definitions options) (apply #'ensure-class name :direct-superclasses superclasses - :direct-slots (uncompress-slot-forms slot-definitions) - options)) + :direct-slots (uncompress-slot-forms slot-definitions) + options)) ;;; ---------------------------------------------------------------------- ;;; ENSURE-CLASS ;;; (defun ensure-class (name &rest initargs) (let* ((old-class nil) - new-class) + new-class) ;; Only classes which have a PROPER name are redefined. If a class ;; with the same name is register, but the name of the class does not ;; correspond to the registered name, a new class is returned. ;; [Hyperspec 7.7 for DEFCLASS] (when name (when (and (setf old-class (find-class name nil)) - (not (eq (class-name old-class) name))) - (setf old-class nil))) + (not (eq (class-name old-class) name))) + (setf old-class nil))) (setf new-class (apply #'ensure-class-using-class old-class name initargs)) new-class)) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index ddece2c14..a72e3fbf7 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -28,26 +28,26 @@ |# (defmethod reader-method-class ((class std-class) - (direct-slot direct-slot-definition) - &rest initargs) + (direct-slot direct-slot-definition) + &rest initargs) (declare (ignore class direct-slot initargs)) (find-class (if (member (class-name (class-of class)) - '(standard-class - funcallable-standard-class - structure-class)) - 'standard-optimized-reader-method - 'standard-reader-method))) + '(standard-class + funcallable-standard-class + structure-class)) + 'standard-optimized-reader-method + 'standard-reader-method))) (defmethod writer-method-class ((class std-class) - (direct-slot direct-slot-definition) - &rest initargs) + (direct-slot direct-slot-definition) + &rest initargs) (declare (ignore class direct-slot initargs)) (find-class (if (member (class-name (class-of class)) - '(standard-class - funcallable-standard-class - structure-class)) - 'standard-optimized-writer-method - 'standard-reader-method))) + '(standard-class + funcallable-standard-class + structure-class)) + 'standard-optimized-writer-method + 'standard-reader-method))) ;;; ---------------------------------------------------------------------- ;;; Fixup @@ -59,8 +59,8 @@ (dolist (method-info *early-methods* (makunbound '*EARLY-METHODS*)) (let* ((method-name (car method-info)) - (gfun (fdefinition method-name)) - (standard-method-class (find-class 'standard-method))) + (gfun (fdefinition method-name)) + (standard-method-class (find-class 'standard-method))) (when (eq 'T (class-id (si:instance-class gfun))) ;; complete the generic function object (si:instance-class-set gfun (find-class 'STANDARD-GENERIC-FUNCTION)) @@ -71,13 +71,13 @@ (dolist (method (cdr method-info)) ;; complete the method object (let ((old-class (si::instance-class method))) - (si::instance-class-set method - (cond ((null old-class) - (find-class 'standard-method)) - ((symbolp old-class) - (find-class (truly-the symbol old-class))) - (t - old-class)))) + (si::instance-class-set method + (cond ((null old-class) + (find-class 'standard-method)) + ((symbolp old-class) + (find-class (truly-the symbol old-class))) + (t + old-class)))) (si::instance-sig-set gfun) (register-method-with-specializers method) ) @@ -91,21 +91,21 @@ (defun make-method (method-class qualifiers specializers arglist function options) (apply #'make-instance - method-class - :generic-function nil - :qualifiers qualifiers - :lambda-list arglist - :specializers specializers - :function function - :allow-other-keys t - options)) + method-class + :generic-function nil + :qualifiers qualifiers + :lambda-list arglist + :specializers specializers + :function function + :allow-other-keys t + options)) (defun all-keywords (l) (declare (si::c-local)) (let ((all-keys '())) (do ((l (rest l) (cddddr l))) - ((null l) - all-keys) + ((null l) + all-keys) (push (first l) all-keys)))) (defun congruent-lambda-p (l1 l2) @@ -113,19 +113,19 @@ (si::process-lambda-list l1 'FUNCTION) (declare (ignore a-o-k1)) (multiple-value-bind (r2 opts2 rest2 key-flag2 keywords2 a-o-k2) - (si::process-lambda-list l2 'FUNCTION) - (and (= (length r2) (length r1)) - (= (length opts1) (length opts2)) - (eq (and (null rest1) (null key-flag1)) - (and (null rest2) (null key-flag2))) - ;; All keywords mentioned in the genericf function - ;; must be accepted by the method. - (or (null key-flag1) - (null key-flag2) - a-o-k2 - (null (set-difference (all-keywords keywords1) - (all-keywords keywords2)))) - t)))) + (si::process-lambda-list l2 'FUNCTION) + (and (= (length r2) (length r1)) + (= (length opts1) (length opts2)) + (eq (and (null rest1) (null key-flag1)) + (and (null rest2) (null key-flag2))) + ;; All keywords mentioned in the genericf function + ;; must be accepted by the method. + (or (null key-flag1) + (null key-flag2) + a-o-k2 + (null (set-difference (all-keywords keywords1) + (all-keywords keywords2)))) + t)))) (defun add-method (gf method) ;; during boot it's a structure accessor @@ -145,11 +145,11 @@ and cannot be added to ~A." method other-gf gf))) ;; (let ((new-lambda-list (method-lambda-list method))) (if (slot-boundp gf 'lambda-list) - (let ((old-lambda-list (generic-function-lambda-list gf))) - (unless (congruent-lambda-p old-lambda-list new-lambda-list) - (error "Cannot add the method ~A to the generic function ~A because ~ + (let ((old-lambda-list (generic-function-lambda-list gf))) + (unless (congruent-lambda-p old-lambda-list new-lambda-list) + (error "Cannot add the method ~A to the generic function ~A because ~ their lambda lists ~A and ~A are not congruent." - method gf old-lambda-list new-lambda-list))) + method gf old-lambda-list new-lambda-list))) (reinitialize-instance gf :lambda-list (implicit-generic-lambda new-lambda-list)))) ;; @@ -158,10 +158,10 @@ their lambda lists ~A and ~A are not congruent." ;; (when (generic-function-methods gf) (let* ((method-qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (found (find-method gf method-qualifiers specializers nil))) + (specializers (method-specializers method)) + (found (find-method gf method-qualifiers specializers nil))) (when found - (remove-method gf found)))) + (remove-method gf found)))) ;; ;; We install the method by: ;; i) Adding it to the list of methods @@ -195,8 +195,8 @@ their lambda lists ~A and ~A are not congruent." (defun remove-method (gf method) (setf (generic-function-methods gf) - (delete method (generic-function-methods gf)) - (method-generic-function method) nil) + (delete method (generic-function-methods gf)) + (method-generic-function method) nil) (si:clear-gfun-hash gf) (loop for spec in (method-specializers method) do (remove-direct-method spec method)) @@ -208,9 +208,9 @@ their lambda lists ~A and ~A are not congruent." (function-to-method 'add-method '((gf standard-generic-function) (method standard-method))) (function-to-method 'remove-method '((gf standard-generic-function) - (method standard-method))) + (method standard-method))) (function-to-method 'find-method '((gf standard-generic-function) - qualifiers specializers &optional error)) + qualifiers specializers &optional error)) ;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places, ;;; including instance initialization. This means we cannot just redefine it. @@ -225,7 +225,7 @@ their lambda lists ~A and ~A are not congruent." (std-compute-applicable-methods gf args)) (let ((aux #'aux-compute-applicable-methods)) (setf (generic-function-name aux) 'compute-applicable-methods - (fdefinition 'compute-applicable-methods) aux)) + (fdefinition 'compute-applicable-methods) aux)) (defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) classes) @@ -249,7 +249,7 @@ their lambda lists ~A and ~A are not congruent." (defun no-primary-method (gf &rest args) (error "Generic function: ~A. No primary method given arguments: ~S" - (generic-function-name gf) args)) + (generic-function-name gf) args)) ;;; Now we protect classes from redefinition: (eval-when (compile load) @@ -259,7 +259,7 @@ their lambda lists ~A and ~A are not congruent." (cond ((typep old-class 'built-in-class) (error "The class associated to the CL specifier ~S cannot be changed." - name)) + name)) ((member name '(CLASS BUILT-IN-CLASS) :test #'eq) (error "The kernel CLOS class ~S cannot be changed." name)) ((classp new-value) @@ -308,7 +308,7 @@ their lambda lists ~A and ~A are not congruent." (mapc #'recursively-update-classes (class-direct-subclasses a-class))) (defmethod update-dependent ((object generic-function) (dep initargs-updater) - &rest initargs) + &rest initargs) (declare (ignore dep initargs object)) (recursively-update-classes +the-class+)) diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 9ec82f086..5dd0ed1c3 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -21,18 +21,18 @@ (parse-lambda-list lambda-list) ;; process options (multiple-value-bind (option-list method-list) - (parse-generic-options options lambda-list) + (parse-generic-options options lambda-list) (let* ((output `(ensure-generic-function ',function-specifier - :delete-methods t ,@option-list))) - (ext:register-with-pde - whole - (if method-list - `(progn - ,output - (associate-methods-to-gfun - ',function-specifier - ,@(loop for m in method-list collect `(defmethod ,function-specifier ,@m)))) - output)))))) + :delete-methods t ,@option-list))) + (ext:register-with-pde + whole + (if method-list + `(progn + ,output + (associate-methods-to-gfun + ',function-specifier + ,@(loop for m in method-list collect `(defmethod ,function-specifier ,@m)))) + output)))))) (defun parse-defgeneric (args) (declare (si::c-local)) @@ -48,67 +48,67 @@ (defun parse-generic-options (options lambda-list) (declare (si::c-local)) (let* ((processed-options '()) - (method-list '()) - (declarations '()) - arg-list) + (method-list '()) + (declarations '()) + arg-list) (dolist (option options) (let ((option-name (first option)) - option-value) - (cond ((eq option-name :method) - ;; We do not need to check the validity of this - ;; because DEFMETHOD will do it. - (push (rest option) method-list)) - ((eq option-name 'declare) - (setf declarations (append (rest option) declarations))) - ((member option-name processed-options) - (simple-program-error "Option ~s specified more than once" - option-name)) - (t - (push option-name processed-options) - ;; We leave much of the type checking for SHARED-INITIALIZE - (setq option-value - (case option-name - (:argument-precedence-order - (rest option)) - (:method-combination - (rest option)) - ((:documentation :generic-function-class :method-class) - (unless (endp (cddr option)) - (simple-program-error "Too many arguments for option ~A" - option-name)) - (second option)) - (otherwise - (simple-program-error "~S is not a legal defgeneric option" - option-name)))) - (setf arg-list `(',option-name ',option-value ,@arg-list)))))) + option-value) + (cond ((eq option-name :method) + ;; We do not need to check the validity of this + ;; because DEFMETHOD will do it. + (push (rest option) method-list)) + ((eq option-name 'declare) + (setf declarations (append (rest option) declarations))) + ((member option-name processed-options) + (simple-program-error "Option ~s specified more than once" + option-name)) + (t + (push option-name processed-options) + ;; We leave much of the type checking for SHARED-INITIALIZE + (setq option-value + (case option-name + (:argument-precedence-order + (rest option)) + (:method-combination + (rest option)) + ((:documentation :generic-function-class :method-class) + (unless (endp (cddr option)) + (simple-program-error "Too many arguments for option ~A" + option-name)) + (second option)) + (otherwise + (simple-program-error "~S is not a legal defgeneric option" + option-name)))) + (setf arg-list `(',option-name ',option-value ,@arg-list)))))) (values `(:lambda-list ',lambda-list ,@arg-list - ,@(when declarations `(:declarations ',declarations))) - method-list))) + ,@(when declarations `(:declarations ',declarations))) + method-list))) (defun parse-lambda-list (lambda-list &optional post-keyword) (declare (si::c-local)) (let ((arg (car lambda-list))) (cond ((null lambda-list)) - ((eq arg '&AUX) - (simple-program-error "&aux is not allowed in a generic function lambda-list")) - ((member arg lambda-list-keywords) - (parse-lambda-list (cdr lambda-list) t)) - (post-keyword - ;; After a lambda-list-keyword there can be no specializers. - (parse-lambda-list (cdr lambda-list) t)) - (t - (if (listp arg) - (simple-program-error "the parameters cannot be specialized in generic function lambda-list") - (parse-lambda-list (cdr lambda-list))))))) + ((eq arg '&AUX) + (simple-program-error "&aux is not allowed in a generic function lambda-list")) + ((member arg lambda-list-keywords) + (parse-lambda-list (cdr lambda-list) t)) + (post-keyword + ;; After a lambda-list-keyword there can be no specializers. + (parse-lambda-list (cdr lambda-list) t)) + (t + (if (listp arg) + (simple-program-error "the parameters cannot be specialized in generic function lambda-list") + (parse-lambda-list (cdr lambda-list))))))) (defun valid-declaration-p (decl) ;(declare (si::c-local)) (and (eq (first decl) 'OPTIMIZE) (loop for item in decl - always (or (atom item) - (and (consp item) - (member (first item) - '(SPEED SPACE COMPILATION-SPEED DEBUG SAFETY))))))) + always (or (atom item) + (and (consp item) + (member (first item) + '(SPEED SPACE COMPILATION-SPEED DEBUG SAFETY))))))) ;;; ---------------------------------------------------------------------- ;;; GENERIC FUNCTION (RE)INITIALIZATION PROTOCOL @@ -118,17 +118,17 @@ (rest (si::process-lambda-list lambda-list t))) (defmethod shared-initialize ((gfun generic-function) slot-names &rest initargs - &key (name nil) - (lambda-list nil l-l-p) - (argument-precedence-order nil a-o-p) - (documentation nil) - (declarations nil) - (method-class (find-class 'method)) - &aux - (gfun-name (if (slot-boundp gfun 'name) - (slot-value gfun 'name) - (or name :anonymous))) - ) + &key (name nil) + (lambda-list nil l-l-p) + (argument-precedence-order nil a-o-p) + (documentation nil) + (declarations nil) + (method-class (find-class 'method)) + &aux + (gfun-name (if (slot-boundp gfun 'name) + (slot-value gfun 'name) + (or name :anonymous))) + ) (declare (ignore initargs slot-names)) ;; ;; Check the validity of several fields. @@ -136,49 +136,49 @@ (when a-o-p (unless l-l-p (simple-program-error "When defining generic function ~A~%Supplied :argument-precedence-order, but :lambda-list is missing" - gfun-name)) + gfun-name)) (dolist (l (lambda-list-required-arguments lambda-list)) (unless (= (count l argument-precedence-order) 1) - (simple-program-error "When defining generic function ~A~%The required argument ~A does not appear exactly once in the ARGUMENT-PRECEDENCE-ORDER list ~A" - gfun-name l argument-precedence-order)))) + (simple-program-error "When defining generic function ~A~%The required argument ~A does not appear exactly once in the ARGUMENT-PRECEDENCE-ORDER list ~A" + gfun-name l argument-precedence-order)))) (unless (every #'valid-declaration-p declarations) (simple-program-error "When defining generic function ~A~%Not a valid declaration list: ~A" - gfun-name declarations)) + gfun-name declarations)) (unless (or (null documentation) (stringp documentation)) (error 'simple-type-error - :format-control "When defining generic function~A~%Not a valid documentation object ~" - :format-arguments (list gfun-name documentation) - :datum documentation - :expected-type '(or null string))) + :format-control "When defining generic function~A~%Not a valid documentation object ~" + :format-arguments (list gfun-name documentation) + :datum documentation + :expected-type '(or null string))) (unless (si::subclassp method-class (find-class 'method)) (error 'simple-type-error - :format-control "When defining generic function~A~%Not a valid method class, ~A" - :format-arguments (list gfun-name method-class) - :datum method-class - :expected-type 'method)) + :format-control "When defining generic function~A~%Not a valid method class, ~A" + :format-arguments (list gfun-name method-class) + :datum method-class + :expected-type 'method)) ;; ;; When supplying a new lambda-list, ensure that it is compatible with ;; the old list of methods. ;; (when (and l-l-p (slot-boundp gfun 'methods)) (unless (every #'(lambda (x) - (congruent-lambda-p lambda-list x)) - (mapcar #'method-lambda-list (generic-function-methods gfun))) + (congruent-lambda-p lambda-list x)) + (mapcar #'method-lambda-list (generic-function-methods gfun))) (simple-program-error "Cannot replace the lambda list of ~A with ~A because it is incongruent with some of the methods" - gfun lambda-list))) + gfun lambda-list))) (call-next-method) (let ((combination (generic-function-method-combination gfun))) (unless (typep combination 'method-combination) (setf (generic-function-method-combination gfun) - (find-method-combination gfun (first combination) (rest combination))))) + (find-method-combination gfun (first combination) (rest combination))))) (when (and l-l-p (not a-o-p)) (setf (generic-function-argument-precedence-order gfun) - (lambda-list-required-arguments lambda-list))) + (lambda-list-required-arguments lambda-list))) (set-generic-function-dispatch gfun) gfun) (defmethod shared-initialize ((gfun standard-generic-function) slot-names - &rest initargs) + &rest initargs) (declare (ignore initargs slot-names)) (call-next-method) (when (generic-function-methods gfun) @@ -210,13 +210,13 @@ (setf generic-function-class (find-class generic-function-class))) (unless (si::subclassp generic-function-class (find-class 'generic-function)) (error "~A is not a valid :GENERIC-FUNCTION-CLASS argument for ENSURE-GENERIC-FUNCTION." - generic-function-class)) + generic-function-class)) (when (and method-class-p (symbolp method-class)) (setf args (list* :method-class (find-class method-class) args))) (when delete-methods (dolist (m (copy-list (generic-function-methods gfun))) (when (getf (method-plist m) :method-from-defgeneric-p) - (remove-method gfun m)))) + (remove-method gfun m)))) (if (eq (class-of gfun) generic-function-class) (apply #'reinitialize-instance gfun args) (apply #'change-class gfun generic-function-class args))) @@ -240,19 +240,19 @@ (defun ensure-generic-function (name &rest args &key &allow-other-keys) (let ((gfun (si::traced-old-definition name))) (cond ((not (legal-generic-function-name-p name)) - (simple-program-error "~A is not a valid generic function name" name)) + (simple-program-error "~A is not a valid generic function name" name)) ((not (fboundp name)) - (setf (fdefinition name) - (apply #'ensure-generic-function-using-class gfun name args))) + (setf (fdefinition name) + (apply #'ensure-generic-function-using-class gfun name args))) ((si::instancep (or gfun (setf gfun (fdefinition name)))) - (apply #'ensure-generic-function-using-class gfun name args)) - ((special-operator-p name) - (simple-program-error "The special operator ~A is not a valid name for a generic function" name)) - ((macro-function name) - (simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) + (apply #'ensure-generic-function-using-class gfun name args)) + ((special-operator-p name) + (simple-program-error "The special operator ~A is not a valid name for a generic function" name)) + ((macro-function name) + (simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) ((not *clos-booted*) (setf (fdefinition name) - (apply #'ensure-generic-function-using-class nil name args)) + (apply #'ensure-generic-function-using-class nil name args)) (fdefinition name)) - (t - (simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))))) + (t + (simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))))) diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index e5be87db5..008769b4c 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -84,8 +84,8 @@ (eval-when (:compile-toplevel :execute) (defparameter +standard-class-slots+ (append +class-slots+ - '((optimize-slot-access) - (forward))))) + '((optimize-slot-access) + (forward))))) ;;; ---------------------------------------------------------------------- ;;; STRUCTURE-CLASS @@ -93,14 +93,14 @@ (eval-when (:compile-toplevel :execute) (defparameter +structure-class-slots+ (append +class-slots+ - '((slot-descriptions) - (initial-offset) - (defstruct-form) - (constructors) - (documentation) - (copier) - (predicate) - (print-function))))) + '((slot-descriptions) + (initial-offset) + (defstruct-form) + (constructors) + (documentation) + (copier) + (predicate) + (print-function))))) ;;; ---------------------------------------------------------------------- ;;; STANDARD-GENERIC-FUNCTION @@ -149,10 +149,10 @@ (defparameter +standard-accessor-method-slots+ (append +standard-method-slots+ - '((slot-definition :initarg :slot-definition - :initform nil - ;; FIXME! Should be a :reader - :accessor accessor-method-slot-definition))))) + '((slot-definition :initarg :slot-definition + :initform nil + ;; FIXME! Should be a :reader + :accessor accessor-method-slot-definition))))) ;;; ---------------------------------------------------------------------- ;;; SLOT-DEFINITION @@ -179,86 +179,86 @@ ;; the code of cl_class_of() in src/instance.d ;; (defconstant +builtin-classes-list+ - '(;(t object) - (sequence) - (list sequence) - (cons list) - (array) - (vector array sequence) - (string vector) + '(;(t object) + (sequence) + (list sequence) + (cons list) + (array) + (vector array sequence) + (string vector) #+unicode - (base-string string vector) - (bit-vector vector) - (stream) - (ext:ansi-stream stream) - (file-stream ext:ansi-stream) - (echo-stream ext:ansi-stream) - (string-stream ext:ansi-stream) - (two-way-stream ext:ansi-stream) - (synonym-stream ext:ansi-stream) - (broadcast-stream ext:ansi-stream) - (concatenated-stream ext:ansi-stream) - (ext:sequence-stream ext:ansi-stream) - (character) - (number) - (real number) - (rational real) - (integer rational) - (fixnum integer) - (bignum integer) - (ratio rational) - (float real) - (complex number) - (symbol) - (null symbol list) - (keyword symbol) - (package) - (function) - (pathname) - (logical-pathname pathname) - (hash-table) - (random-state) - (readtable) + (base-string string vector) + (bit-vector vector) + (stream) + (ext:ansi-stream stream) + (file-stream ext:ansi-stream) + (echo-stream ext:ansi-stream) + (string-stream ext:ansi-stream) + (two-way-stream ext:ansi-stream) + (synonym-stream ext:ansi-stream) + (broadcast-stream ext:ansi-stream) + (concatenated-stream ext:ansi-stream) + (ext:sequence-stream ext:ansi-stream) + (character) + (number) + (real number) + (rational real) + (integer rational) + (fixnum integer) + (bignum integer) + (ratio rational) + (float real) + (complex number) + (symbol) + (null symbol list) + (keyword symbol) + (package) + (function) + (pathname) + (logical-pathname pathname) + (hash-table) + (random-state) + (readtable) (si::code-block) - (si::foreign-data) - (si::frame) - (si::weak-pointer) - #+threads (mp::process) - #+threads (mp::lock) - #+threads (mp::rwlock) - #+threads (mp::condition-variable) - #+threads (mp::semaphore) - #+threads (mp::barrier) - #+threads (mp::mailbox) - #+sse2 (ext::sse-pack)))) + (si::foreign-data) + (si::frame) + (si::weak-pointer) + #+threads (mp::process) + #+threads (mp::lock) + #+threads (mp::rwlock) + #+threads (mp::condition-variable) + #+threads (mp::semaphore) + #+threads (mp::barrier) + #+threads (mp::mailbox) + #+sse2 (ext::sse-pack)))) ;;; FROM AMOP: ;;; -;;; Metaobject Class Direct Superclasses -;;; standard-object (t) -;;; funcallable-standard-object (standard-object function) -;;; * metaobject (standard-object) -;;; * generic-function (metaobject funcallable-standard-object) -;;; standard-generic-function (generic-function) -;;; * method (metaobject) -;;; standard-method (method) -;;; * standard-accessor-method (standard-method) -;;; standard-reader-method (standard-accessor-method) -;;; standard-writer-method (standard-accessor-method) -;;; * method-combination (metaobject) -;;; * slot-definition (metaobject) -;;; * direct-slot-definition (slot-definition) -;;; * effective-slot-definition (slot-definition) -;;; * standard-slot-definition (slot-definition) -;;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition) -;;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition) -;;; * specializer (metaobject) -;;; eql-specializer (specializer) -;;; * class (specializer) -;;; built-in-class (class) -;;; forward-referenced-class (class) -;;; standard-class (class) -;;; funcallable-standard-class (class) +;;; Metaobject Class Direct Superclasses +;;; standard-object (t) +;;; funcallable-standard-object (standard-object function) +;;; * metaobject (standard-object) +;;; * generic-function (metaobject funcallable-standard-object) +;;; standard-generic-function (generic-function) +;;; * method (metaobject) +;;; standard-method (method) +;;; * standard-accessor-method (standard-method) +;;; standard-reader-method (standard-accessor-method) +;;; standard-writer-method (standard-accessor-method) +;;; * method-combination (metaobject) +;;; * slot-definition (metaobject) +;;; * direct-slot-definition (slot-definition) +;;; * effective-slot-definition (slot-definition) +;;; * standard-slot-definition (slot-definition) +;;; standard-direct-slot-definition (standard-slot-definition direct-slot-definition) +;;; standard-effective-slot-definition (standard-slot-definition effective-slot-definition) +;;; * specializer (metaobject) +;;; eql-specializer (specializer) +;;; * class (specializer) +;;; built-in-class (class) +;;; forward-referenced-class (class) +;;; standard-class (class) +;;; funcallable-standard-class (class) ;;; (eval-when (eval) (defconstant +class-hierarchy+ @@ -325,10 +325,10 @@ :direct-superclasses (std-class) :direct-slots #1#) ,@(loop for (name . rest) in +builtin-classes-list+ - for index from 1 - collect (list name :metaclass 'built-in-class - :index index - :direct-superclasses (or rest '(t)))) + for index from 1 + collect (list name :metaclass 'built-in-class + :index index + :direct-superclasses (or rest '(t)))) (funcallable-standard-object :direct-superclasses (standard-object function)) (generic-function diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp index b749300c3..65ef793ff 100644 --- a/src/clos/inspect.lsp +++ b/src/clos/inspect.lsp @@ -18,71 +18,71 @@ (defmethod select-clos-N ((instance standard-object)) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class)) - (class-slotds (class-class-slots class))) + (local-slotds (class-local-slots class)) + (class-slotds (class-class-slots class))) (if local-slotds - (progn - (si::inspect-indent) - (format t "The local slots are:~%") - (incf si::*inspect-level*) - (dolist (slotd local-slotds) - (si::inspect-indent-1) - (format t "name : ~S" (clos::slot-definition-name slotd)) - (if (slot-boundp instance (clos::slot-definition-name slotd)) - (si::inspect-recursively "value:" - (slot-value instance (clos::slot-definition-name slotd)) - (slot-value instance (clos::slot-definition-name slotd))) - (si::inspect-print "value: Unbound" - nil - (slot-value instance (clos::slot-definition-name slotd))))) - (decf si::*inspect-level*)) - (progn - (si::inspect-indent) - (format t "It has no local slots.~%"))) - (if class-slotds - (progn - (si::inspect-indent) - (format t "The class slots are:~%") - (incf si::*inspect-level*) - (dolist (slotd class-slotds) - (si::inspect-indent-1) - (format t "name : ~S" (clos::slot-definition-name slotd)) - (if (slot-boundp instance (clos::slot-definition-name slotd)) - (si::inspect-recursively "value:" - (slot-value instance (clos::slot-definition-name slotd)) - (slot-value instance (clos::slot-definition-name slotd))) - (si::inspect-print "value: Unbound" - nil - (slot-value instance (clos::slot-definition-name slotd))))) - (decf si::*inspect-level*)) - (progn - (si::inspect-indent) - (format t "It has no class slots.~%"))))) + (progn + (si::inspect-indent) + (format t "The local slots are:~%") + (incf si::*inspect-level*) + (dolist (slotd local-slotds) + (si::inspect-indent-1) + (format t "name : ~S" (clos::slot-definition-name slotd)) + (if (slot-boundp instance (clos::slot-definition-name slotd)) + (si::inspect-recursively "value:" + (slot-value instance (clos::slot-definition-name slotd)) + (slot-value instance (clos::slot-definition-name slotd))) + (si::inspect-print "value: Unbound" + nil + (slot-value instance (clos::slot-definition-name slotd))))) + (decf si::*inspect-level*)) + (progn + (si::inspect-indent) + (format t "It has no local slots.~%"))) + (if class-slotds + (progn + (si::inspect-indent) + (format t "The class slots are:~%") + (incf si::*inspect-level*) + (dolist (slotd class-slotds) + (si::inspect-indent-1) + (format t "name : ~S" (clos::slot-definition-name slotd)) + (if (slot-boundp instance (clos::slot-definition-name slotd)) + (si::inspect-recursively "value:" + (slot-value instance (clos::slot-definition-name slotd)) + (slot-value instance (clos::slot-definition-name slotd))) + (si::inspect-print "value: Unbound" + nil + (slot-value instance (clos::slot-definition-name slotd))))) + (decf si::*inspect-level*)) + (progn + (si::inspect-indent) + (format t "It has no class slots.~%"))))) (defun select-clos-N-inner-class (instance) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class))) + (local-slotds (class-local-slots class))) (if local-slotds - (progn - (si::inspect-indent) - (format t "The (local) slots are:~%") - (incf si::*inspect-level*) - (dolist (slotd local-slotds) - (si::inspect-indent-1) - (format t "name : ~S" (clos::slot-definition-name slotd)) - (if (slot-boundp instance (clos::slot-definition-name slotd)) - (si::inspect-recursively "value:" - (slot-value instance (clos::slot-definition-name slotd)) -; (slot-value instance (clos::slot-definition-name slotd)) - ) - (si::inspect-print "value: Unbound" - nil -; (slot-value instance (clos::slot-definition-name slotd)) - ))) - (decf si::*inspect-level*)) - (progn - (si::inspect-indent) - (format t "It has no (local) slots.~%"))))) + (progn + (si::inspect-indent) + (format t "The (local) slots are:~%") + (incf si::*inspect-level*) + (dolist (slotd local-slotds) + (si::inspect-indent-1) + (format t "name : ~S" (clos::slot-definition-name slotd)) + (if (slot-boundp instance (clos::slot-definition-name slotd)) + (si::inspect-recursively "value:" + (slot-value instance (clos::slot-definition-name slotd)) +; (slot-value instance (clos::slot-definition-name slotd)) + ) + (si::inspect-print "value: Unbound" + nil +; (slot-value instance (clos::slot-definition-name slotd)) + ))) + (decf si::*inspect-level*)) + (progn + (si::inspect-indent) + (format t "It has no (local) slots.~%"))))) (defmethod select-clos-N ((instance std-class)) (select-clos-N-inner-class instance)) @@ -92,38 +92,38 @@ (defmethod select-clos-L ((instance standard-object)) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class)) - (class-slotds (class-class-slots class))) + (local-slotds (class-local-slots class)) + (class-slotds (class-class-slots class))) (terpri) - (if local-slotds - (progn - (format t "The names of the local slots are:~%") - (dolist (slotd local-slotds) - (format t " ~S~%" (clos::slot-definition-name slotd)))) - (progn - (format t "It has no local slots.~%"))) - (terpri) - (if class-slotds - (progn - (format t "The names of the class slots are:~%") - (dolist (slotd class-slotds) - (format t " ~S~%" (clos::slot-definition-name slotd)))) - (progn - (format t "It has no class slots.~%"))) - (terpri))) + (if local-slotds + (progn + (format t "The names of the local slots are:~%") + (dolist (slotd local-slotds) + (format t " ~S~%" (clos::slot-definition-name slotd)))) + (progn + (format t "It has no local slots.~%"))) + (terpri) + (if class-slotds + (progn + (format t "The names of the class slots are:~%") + (dolist (slotd class-slotds) + (format t " ~S~%" (clos::slot-definition-name slotd)))) + (progn + (format t "It has no class slots.~%"))) + (terpri))) (defun select-clos-L-inner-class (instance) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class))) + (local-slotds (class-local-slots class))) (terpri) - (if local-slotds - (progn - (format t "The names of the (local) slots are:~%") - (dolist (slotd local-slotds) - (format t " ~S~%" (clos::slot-definition-name slotd)))) - (progn - (format t "It has no (local) slots.~%"))) - (terpri))) + (if local-slotds + (progn + (format t "The names of the (local) slots are:~%") + (dolist (slotd local-slotds) + (format t " ~S~%" (clos::slot-definition-name slotd)))) + (progn + (format t "It has no (local) slots.~%"))) + (terpri))) (defmethod select-clos-L ((instance std-class)) (select-clos-L-inner-class instance)) @@ -133,62 +133,62 @@ (defmethod select-clos-J ((instance standard-object)) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class)) - (class-slotds (class-class-slots class)) - (slotd (car (member (prog1 - (read-preserving-whitespace *query-io*) - (si::inspect-read-line)) - (append local-slotds class-slotds) - :key #'clos::slot-definition-name - :test #'eq)))) + (local-slotds (class-local-slots class)) + (class-slotds (class-class-slots class)) + (slotd (car (member (prog1 + (read-preserving-whitespace *query-io*) + (si::inspect-read-line)) + (append local-slotds class-slotds) + :key #'clos::slot-definition-name + :test #'eq)))) (if slotd - (progn - (incf si::*inspect-level*) - (si::inspect-indent-1) - (format t "name : ~S" (clos::slot-definition-name slotd)) - (if (slot-boundp instance (clos::slot-definition-name slotd)) - (si::inspect-recursively "value:" - (slot-value instance (clos::slot-definition-name slotd)) - (slot-value instance (clos::slot-definition-name slotd))) - (si::inspect-print "value: Unbound" - nil - (slot-value instance (clos::slot-definition-name slotd)))) - (decf si::*inspect-level*)) - (progn - (terpri) - (format t "~S is not a slot of the instance." (slot-definition-name slotd)) - (terpri) - (terpri))))) + (progn + (incf si::*inspect-level*) + (si::inspect-indent-1) + (format t "name : ~S" (clos::slot-definition-name slotd)) + (if (slot-boundp instance (clos::slot-definition-name slotd)) + (si::inspect-recursively "value:" + (slot-value instance (clos::slot-definition-name slotd)) + (slot-value instance (clos::slot-definition-name slotd))) + (si::inspect-print "value: Unbound" + nil + (slot-value instance (clos::slot-definition-name slotd)))) + (decf si::*inspect-level*)) + (progn + (terpri) + (format t "~S is not a slot of the instance." (slot-definition-name slotd)) + (terpri) + (terpri))))) (defun select-clos-J-inner-class (instance) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class)) - (slotd (car (member (prog1 - (read-preserving-whitespace *query-io*) - (si::inspect-read-line)) - local-slotds - :key #'clos::slot-definition-name - :test #'eq)))) + (local-slotds (class-local-slots class)) + (slotd (car (member (prog1 + (read-preserving-whitespace *query-io*) + (si::inspect-read-line)) + local-slotds + :key #'clos::slot-definition-name + :test #'eq)))) (if slotd - (progn - (incf si::*inspect-level*) - (si::inspect-indent-1) - (format t "name : ~S" (clos::slot-definition-name slotd)) - (if (slot-boundp instance (clos::slot-definition-name slotd)) - (si::inspect-recursively "value:" - (slot-value instance (clos::slot-definition-name slotd)) -; (slot-value instance (clos::slot-definition-name slotd)) - ) - (si::inspect-print "value: Unbound" - nil -; (slot-value instance (clos::slot-definition-name slotd)) - )) - (decf si::*inspect-level*)) - (progn - (terpri) - (format t "~S is not a slot of the instance." (slot-definition-name slotd)) - (terpri) - (terpri))))) + (progn + (incf si::*inspect-level*) + (si::inspect-indent-1) + (format t "name : ~S" (clos::slot-definition-name slotd)) + (if (slot-boundp instance (clos::slot-definition-name slotd)) + (si::inspect-recursively "value:" + (slot-value instance (clos::slot-definition-name slotd)) +; (slot-value instance (clos::slot-definition-name slotd)) + ) + (si::inspect-print "value: Unbound" + nil +; (slot-value instance (clos::slot-definition-name slotd)) + )) + (decf si::*inspect-level*)) + (progn + (terpri) + (format t "~S is not a slot of the instance." (slot-definition-name slotd)) + (terpri) + (terpri))))) (defmethod select-clos-J ((instance std-class)) (select-clos-J-inner-class instance)) @@ -200,7 +200,7 @@ (declare (si::c-local)) (terpri) (format t - "Inspect commands for clos instances:~%~ + "Inspect commands for clos instances:~%~ n (or N or Newline): inspects all slots of the class (recursively).~%~ s (or S): skips the field.~%~ p (or P): pretty-prints the field.~%~ @@ -210,7 +210,7 @@ l (or L): show the names of all slots.~%~ j (or J) slot-name: inspect the slot with the name requested.~%~ q (or Q): quits the inspection.~%~ ?: prints this.~%~%" - )) + )) (defun class-local-slots (class) (remove :class (class-slots class) :key #'clos::slot-definition-allocation)) @@ -228,52 +228,52 @@ q (or Q): quits the inspection.~%~ (throw 'SI::ABORT-INSPECT nil)) (decf si::*inspect-level*) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class)) - (class-slotds (class-class-slots class))) + (local-slotds (class-local-slots class)) + (class-slotds (class-class-slots class))) (declare (type class class)) (loop (format t "~S - clos object:" instance) (incf si::*inspect-level*) (si::inspect-indent) (format t "- it is an instance of class named ~S," - (class-name class)) + (class-name class)) (si::inspect-indent) (format t "- it has ~A local slots and ~A class slots: " - (length local-slotds) (length class-slotds)) + (length local-slotds) (length class-slotds)) (force-output) (case (do ((char (read-char *query-io*) (read-char *query-io*))) - ((and (char/= char #\Space) (char/= #\Tab)) char)) - ((#\Newline #\Return) - (select-clos-N instance) - (return nil)) - ((#\n #\N) - (si::inspect-read-line) - (select-clos-N instance) - (return nil)) - ((#\s #\S) - (si::inspect-read-line) - (return nil)) - ((#\p #\P) - (si::inspect-read-line) - (si::select-P instance)) - ((#\a #\A) - (si::inspect-read-line) - (throw 'SI::ABORT-INSPECT nil)) - ((#\e #\E) - (si::select-E)) - ((#\q #\Q) - (si::inspect-read-line) - (throw 'SI::QUIT-INSPECT nil)) - ((#\l #\L) - (si::inspect-read-line) - (select-clos-L instance)) - ((#\j #\J) - (select-clos-J instance)) - ((#\?) - (si::inspect-read-line) - (select-clos-?)) - (t - (si::inspect-read-line))) + ((and (char/= char #\Space) (char/= #\Tab)) char)) + ((#\Newline #\Return) + (select-clos-N instance) + (return nil)) + ((#\n #\N) + (si::inspect-read-line) + (select-clos-N instance) + (return nil)) + ((#\s #\S) + (si::inspect-read-line) + (return nil)) + ((#\p #\P) + (si::inspect-read-line) + (si::select-P instance)) + ((#\a #\A) + (si::inspect-read-line) + (throw 'SI::ABORT-INSPECT nil)) + ((#\e #\E) + (si::select-E)) + ((#\q #\Q) + (si::inspect-read-line) + (throw 'SI::QUIT-INSPECT nil)) + ((#\l #\L) + (si::inspect-read-line) + (select-clos-L instance)) + ((#\j #\J) + (select-clos-J instance)) + ((#\?) + (si::inspect-read-line) + (select-clos-?)) + (t + (si::inspect-read-line))) (decf si::*inspect-level*) (si::inspect-indent))) (incf si::*inspect-level*)) @@ -281,50 +281,50 @@ q (or Q): quits the inspection.~%~ (defun inspect-obj-inner-class (instance) (decf si::*inspect-level*) (let* ((class (si:instance-class instance)) - (local-slotds (class-local-slots class))) + (local-slotds (class-local-slots class))) (declare (type class class)) (loop (format t "~S - clos object:" instance) (incf si::*inspect-level*) (si::inspect-indent) (format t "- it is an instance of class named ~S," - (class-name class)) + (class-name class)) (si::inspect-indent) (format t "- it has ~A local slots: " (length local-slotds)) (force-output) (case (do ((char (read-char *query-io*) (read-char *query-io*))) - ((and (char/= char #\Space) (char/= #\Tab)) char)) - ((#\Newline #\Return) - (select-clos-N instance) - (return nil)) - ((#\n #\N) - (si::inspect-read-line) - (select-clos-N instance) - (return nil)) - ((#\s #\S) - (si::inspect-read-line) - (return nil)) - ((#\p #\P) - (si::inspect-read-line) - (si::select-P instance)) - ((#\a #\A) - (si::inspect-read-line) - (throw 'SI::ABORT-INSPECT nil)) - ((#\e #\E) - (si::select-E)) - ((#\q #\Q) - (si::inspect-read-line) - (throw 'SI::QUIT-INSPECT nil)) - ((#\l #\L) - (si::inspect-read-line) - (select-clos-L instance)) - ((#\j #\J) - (select-clos-J instance)) - ((#\?) - (si::inspect-read-line) - (select-clos-?)) - (t - (si::inspect-read-line))) + ((and (char/= char #\Space) (char/= #\Tab)) char)) + ((#\Newline #\Return) + (select-clos-N instance) + (return nil)) + ((#\n #\N) + (si::inspect-read-line) + (select-clos-N instance) + (return nil)) + ((#\s #\S) + (si::inspect-read-line) + (return nil)) + ((#\p #\P) + (si::inspect-read-line) + (si::select-P instance)) + ((#\a #\A) + (si::inspect-read-line) + (throw 'SI::ABORT-INSPECT nil)) + ((#\e #\E) + (si::select-E)) + ((#\q #\Q) + (si::inspect-read-line) + (throw 'SI::QUIT-INSPECT nil)) + ((#\l #\L) + (si::inspect-read-line) + (select-clos-L instance)) + ((#\j #\J) + (select-clos-J instance)) + ((#\?) + (si::inspect-read-line) + (select-clos-?)) + (t + (si::inspect-read-line))) (decf si::*inspect-level*) (si::inspect-indent))) (incf si::*inspect-level*)) @@ -352,15 +352,15 @@ q (or Q): quits the inspection.~%~ (case doc-type (type (let ((c (find-class object nil))) - (if c - (documentation c t) - (si::get-documentation object doc-type)))) + (if c + (documentation c t) + (si::get-documentation object doc-type)))) (function (or (si::get-documentation object doc-type) - (and (fboundp object) - (documentation (or (macro-function object) - (fdefinition object)) - doc-type)))) + (and (fboundp object) + (documentation (or (macro-function object) + (fdefinition object)) + doc-type)))) (otherwise (si::get-documentation object doc-type))))) @@ -369,18 +369,18 @@ q (or Q): quits the inspection.~%~ (case doc-type (type (let ((c (find-class object nil))) - (if c - (progn - (si::set-documentation object 'type nil) - (si::set-documentation object 'structure nil) - (setf (documentation c t) new-value)) - (si::set-documentation object doc-type new-value)))) + (if c + (progn + (si::set-documentation object 'type nil) + (si::set-documentation object 'structure nil) + (setf (documentation c t) new-value)) + (si::set-documentation object doc-type new-value)))) (function (if (fboundp object) - (let ((c (or (macro-function object) (fdefinition object)))) - (si::set-documentation c 'function nil) - (setf (documentation c 'function) new-value)) - (si::set-documentation object doc-type new-value))) + (let ((c (or (macro-function object) (fdefinition object)))) + (si::set-documentation c 'function nil) + (setf (documentation c 'function) new-value)) + (si::set-documentation object doc-type new-value))) (otherwise (si::set-documentation object doc-type new-value)))) new-value) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 48d83f2b6..35d6939a1 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -35,11 +35,11 @@ (let ((old-class (find-class name nil))) (cond ((and old-class - (or (typep old-class 'built-in-class) - (member name '(class built-in-class) :test #'eq))) + (or (typep old-class 'built-in-class) + (member name '(class built-in-class) :test #'eq))) (unless (eq new-value old-class) - (error "The class associated to the CL specifier ~S cannot be changed." - name))) + (error "The class associated to the CL specifier ~S cannot be changed." + name))) ((classp new-value) (setf (gethash name si:*class-name-hash-table*) new-value)) ((null new-value) (remhash name si:*class-name-hash-table*)) @@ -51,11 +51,11 @@ (defun classp (obj) (and (si:instancep obj) (let ((topmost (find-class 'CLASS nil))) - ;; All instances can be classes until the class CLASS has - ;; been installed. Otherwise, we check the parents. - ;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost)))) - (or (null topmost) - (si::subclassp (si::instance-class obj) topmost))) + ;; All instances can be classes until the class CLASS has + ;; been installed. Otherwise, we check the parents. + ;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost)))) + (or (null topmost) + (si::subclassp (si::instance-class obj) topmost))) t)) ;;; ---------------------------------------------------------------------- @@ -65,17 +65,17 @@ (declare (notinline ensure-generic-function)) ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name)) - (fun (if wrap (wrapped-method-function fun) fun)) - (specializers (mapcar #'(lambda (x) - (cond ((consp x) (intern-eql-specializer (second x))) - ((typep x 'specializer) x) - ((find-class x nil)) - (t - (error "In method definition for ~A, found an invalid specializer ~A" name specializers)))) - specializers)) - (method (make-method (generic-function-method-class gf) - qualifiers specializers lambda-list - fun options))) + (fun (if wrap (wrapped-method-function fun) fun)) + (specializers (mapcar #'(lambda (x) + (cond ((consp x) (intern-eql-specializer (second x))) + ((typep x 'specializer) x) + ((find-class x nil)) + (t + (error "In method definition for ~A, found an invalid specializer ~A" name specializers)))) + specializers)) + (method (make-method (generic-function-method-class gf) + qualifiers specializers lambda-list + fun options))) (add-method gf method) method)) @@ -93,23 +93,23 @@ (fdefinition name) ;; create a fake standard-generic-function object: (with-early-make-instance +standard-generic-function-slots+ - (gfun (find-class 'standard-generic-function) - :name name - :spec-list nil - :method-combination (find-method-combination nil 'standard nil) - :lambda-list lambda-list - :argument-precedence-order - (and l-l-p (rest (si::process-lambda-list lambda-list t))) - :method-class (find-class 'standard-method) - :docstring nil - :methods nil - :a-p-o-function nil - :declarations nil - :dependents nil) - ;; create a new gfun - (set-funcallable-instance-function gfun 'standard-generic-function) - (setf (fdefinition name) gfun) - gfun))) + (gfun (find-class 'standard-generic-function) + :name name + :spec-list nil + :method-combination (find-method-combination nil 'standard nil) + :lambda-list lambda-list + :argument-precedence-order + (and l-l-p (rest (si::process-lambda-list lambda-list t))) + :method-class (find-class 'standard-method) + :docstring nil + :methods nil + :a-p-o-function nil + :declarations nil + :dependents nil) + ;; create a new gfun + (set-funcallable-instance-function gfun 'standard-generic-function) + (setf (fdefinition name) gfun) + gfun))) (defun (setf generic-function-name) (new-name gf) (if *clos-booted* @@ -118,47 +118,47 @@ (defun default-dispatch (generic-function) (cond ((null *clos-booted*) - 'standard-generic-function) - ((eq (class-id (class-of generic-function)) - 'standard-generic-function) - 'standard-generic-function) - (t))) + 'standard-generic-function) + ((eq (class-id (class-of generic-function)) + 'standard-generic-function) + 'standard-generic-function) + (t))) (defun compute-discriminating-function (generic-function) (values #'(lambda (&rest args) - (multiple-value-bind (method-list ok) - (compute-applicable-methods-using-classes - generic-function - (mapcar #'class-of args)) - (unless ok - (setf method-list - (compute-applicable-methods generic-function args)) - (unless method-list - (apply #'no-applicable-method generic-function args))) - (funcall (compute-effective-method-function - generic-function - (generic-function-method-combination generic-function) - method-list) - args - nil))) - t)) + (multiple-value-bind (method-list ok) + (compute-applicable-methods-using-classes + generic-function + (mapcar #'class-of args)) + (unless ok + (setf method-list + (compute-applicable-methods generic-function args)) + (unless method-list + (apply #'no-applicable-method generic-function args))) + (funcall (compute-effective-method-function + generic-function + (generic-function-method-combination generic-function) + method-list) + args + nil))) + t)) (defun set-generic-function-dispatch (gfun) ;; ;; We have to decide which discriminating function to install: - ;; 1* One supplied by the user - ;; 2* One coded in C that follows the MOP - ;; 3* One in C specialized for slot accessors - ;; 4* One in C that does not use generic versions of compute-applicable-... + ;; 1* One supplied by the user + ;; 2* One coded in C that follows the MOP + ;; 3* One in C specialized for slot accessors + ;; 4* One in C that does not use generic versions of compute-applicable-... ;; Respectively - ;; 1* The user supplies a discriminating function, or the number of arguments - ;; is so large that they cannot be handled by the C dispatchers with - ;; with memoization. - ;; 2* The generic function is not a s-g-f but takes less than 64 arguments - ;; 3* The generic function is a standard-generic-function and all its slots - ;; are standard-{reader,writer}-slots - ;; 4* The generic function is a standard-generic-function with less - ;; than 64 arguments + ;; 1* The user supplies a discriminating function, or the number of arguments + ;; is so large that they cannot be handled by the C dispatchers with + ;; with memoization. + ;; 2* The generic function is not a s-g-f but takes less than 64 arguments + ;; 3* The generic function is a standard-generic-function and all its slots + ;; are standard-{reader,writer}-slots + ;; 4* The generic function is a standard-generic-function with less + ;; than 64 arguments ;; ;; This chain of reasoning uses the fact that the user cannot override methods ;; such as COMPUTE-APPLICABLE-METHODS, or COMPUTE-EFFECTIVE-METHOD, or @@ -176,30 +176,30 @@ (set-funcallable-instance-function gfun (cond - ;; Case 1* - ((or (not optimizable) - (> (length (slot-value gfun 'spec-list)) - si::c-arguments-limit)) - default-function) - ;; Case 2* - ((and (not (eq (slot-value (class-of gfun) 'name) - 'standard-generic-function)) - *clos-booted*) - t) - ((null methods) - 'standard-generic-function) - ;; Cases 3* - ((loop with class = (find-class 'standard-optimized-reader-method nil) - for m in methods - always (eq class (class-of m))) - 'standard-optimized-reader-method) - ((loop with class = (find-class 'standard-optimized-writer-method nil) - for m in methods - always (eq class (class-of m))) - 'standard-optimized-writer-method) - ;; Case 4* - (t - 'standard-generic-function)))))) + ;; Case 1* + ((or (not optimizable) + (> (length (slot-value gfun 'spec-list)) + si::c-arguments-limit)) + default-function) + ;; Case 2* + ((and (not (eq (slot-value (class-of gfun) 'name) + 'standard-generic-function)) + *clos-booted*) + t) + ((null methods) + 'standard-generic-function) + ;; Cases 3* + ((loop with class = (find-class 'standard-optimized-reader-method nil) + for m in methods + always (eq class (class-of m))) + 'standard-optimized-reader-method) + ((loop with class = (find-class 'standard-optimized-writer-method nil) + for m in methods + always (eq class (class-of m))) + 'standard-optimized-writer-method) + ;; Case 4* + (t + 'standard-generic-function)))))) ;;; ---------------------------------------------------------------------- ;;; COMPUTE-APPLICABLE-METHODS @@ -225,96 +225,96 @@ (defun applicable-method-list (gf args) (declare (optimize (speed 3)) - (si::c-local)) + (si::c-local)) (with-early-accessors (+standard-method-slots+ - +standard-generic-function-slots+ - +eql-specializer-slots+ - +standard-class-slots+) + +standard-generic-function-slots+ + +eql-specializer-slots+ + +standard-class-slots+) (flet ((applicable-method-p (method args) - (loop for spec in (method-specializers method) - for arg in args - always (if (eql-specializer-flag spec) - (eql arg (eql-specializer-object spec)) - (si::of-class-p arg spec))))) + (loop for spec in (method-specializers method) + for arg in args + always (if (eql-specializer-flag spec) + (eql arg (eql-specializer-object spec)) + (si::of-class-p arg spec))))) (loop for method in (generic-function-methods gf) - when (applicable-method-p method args) - collect method)))) + when (applicable-method-p method args) + collect method)))) (defun std-compute-applicable-methods-using-classes (gf classes) (declare (optimize (speed 3))) (with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+) (flet ((applicable-method-p (method classes) - (loop for spec in (method-specializers method) - for class in classes - always (cond ((eql-specializer-flag spec) - ;; EQL specializer invalidate computation - ;; we return NIL - (when (si::of-class-p (eql-specializer-object spec) class) - (return-from std-compute-applicable-methods-using-classes - (values nil nil))) - nil) - ((si::subclassp class spec)))))) + (loop for spec in (method-specializers method) + for class in classes + always (cond ((eql-specializer-flag spec) + ;; EQL specializer invalidate computation + ;; we return NIL + (when (si::of-class-p (eql-specializer-object spec) class) + (return-from std-compute-applicable-methods-using-classes + (values nil nil))) + nil) + ((si::subclassp class spec)))))) (values (sort-applicable-methods - gf - (loop for method in (generic-function-methods gf) - when (applicable-method-p method classes) - collect method) - classes) - t)))) + gf + (loop for method in (generic-function-methods gf) + when (applicable-method-p method classes) + collect method) + classes) + t)))) (defun sort-applicable-methods (gf applicable-list args) (declare (optimize (safety 0) (speed 3))) (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+) (let ((f (generic-function-a-p-o-function gf)) - (args-specializers (mapcar #'class-of args))) + (args-specializers (mapcar #'class-of args))) ;; reorder args to match the precedence order (when f - (setf args-specializers - (funcall f (subseq args-specializers 0 - (length (generic-function-argument-precedence-order gf)))))) + (setf args-specializers + (funcall f (subseq args-specializers 0 + (length (generic-function-argument-precedence-order gf)))))) ;; then order the list (do* ((scan applicable-list) - (most-specific (first scan) (first scan)) - (ordered-list)) - ((null (cdr scan)) - (when most-specific - ;; at least one method - (nreverse - (push most-specific ordered-list)))) - (dolist (meth (cdr scan)) - (when (eq (compare-methods most-specific - meth args-specializers f) 2) - (setq most-specific meth))) - (setq scan (delete most-specific scan)) - (push most-specific ordered-list))))) + (most-specific (first scan) (first scan)) + (ordered-list)) + ((null (cdr scan)) + (when most-specific + ;; at least one method + (nreverse + (push most-specific ordered-list)))) + (dolist (meth (cdr scan)) + (when (eq (compare-methods most-specific + meth args-specializers f) 2) + (setq most-specific meth))) + (setq scan (delete most-specific scan)) + (push most-specific ordered-list))))) (defun compare-methods (method-1 method-2 args-specializers f) (declare (si::c-local)) (with-early-accessors (+standard-method-slots+) (let* ((specializers-list-1 (method-specializers method-1)) - (specializers-list-2 (method-specializers method-2))) + (specializers-list-2 (method-specializers method-2))) (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1) - (if f (funcall f specializers-list-2) specializers-list-2) - args-specializers)))) + (if f (funcall f specializers-list-2) specializers-list-2) + args-specializers)))) (defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers) (declare (si::c-local)) (when (or spec-list-1 spec-list-2) (ecase (compare-specializers (first spec-list-1) - (first spec-list-2) - (first args-specializers)) + (first spec-list-2) + (first args-specializers)) (1 '1) (2 '2) (= (compare-specializers-lists (cdr spec-list-1) - (cdr spec-list-2) - (cdr args-specializers))) + (cdr spec-list-2) + (cdr args-specializers))) ((nil) (error "The type specifiers ~S and ~S can not be disambiguated~ with respect to the argument specializer: ~S" - (or (car spec-list-1) t) - (or (car spec-list-2) t) - (car args-specializers))))) + (or (car spec-list-1) t) + (or (car spec-list-2) t) + (car args-specializers))))) ) (defun fast-subtypep (spec1 spec2) @@ -323,75 +323,75 @@ ;; and spec2 are either classes or of the form (EQL x) (with-early-accessors (+eql-specializer-slots+ +standard-class-slots+) (if (eql-specializer-flag spec1) - (if (eql-specializer-flag spec2) - (eql (eql-specializer-object spec1) - (eql-specializer-object spec2)) - (si::of-class-p (eql-specializer-object spec1) spec2)) - (if (eql-specializer-flag spec2) - ;; There is only one class with a single element, which - ;; is NULL = (MEMBER NIL). - (and (null (eql-specializer-object spec2)) - (eq (class-name spec1) 'null)) - (si::subclassp spec1 spec2))))) + (if (eql-specializer-flag spec2) + (eql (eql-specializer-object spec1) + (eql-specializer-object spec2)) + (si::of-class-p (eql-specializer-object spec1) spec2)) + (if (eql-specializer-flag spec2) + ;; There is only one class with a single element, which + ;; is NULL = (MEMBER NIL). + (and (null (eql-specializer-object spec2)) + (eq (class-name spec1) 'null)) + (si::subclassp spec1 spec2))))) (defun compare-specializers (spec-1 spec-2 arg-class) (declare (si::c-local)) (with-early-accessors (+standard-class-slots+ +standard-class-slots+) (let* ((cpl (class-precedence-list arg-class))) (cond ((eq spec-1 spec-2) '=) - ((fast-subtypep spec-1 spec-2) '1) - ((fast-subtypep spec-2 spec-1) '2) - ((eql-specializer-flag spec-1) '1) ; is this engough? - ((eql-specializer-flag spec-2) '2) ; Beppe - ((member spec-1 (member spec-2 cpl)) '2) - ((member spec-2 (member spec-1 cpl)) '1) - ;; This will force an error in the caller - (t nil))))) + ((fast-subtypep spec-1 spec-2) '1) + ((fast-subtypep spec-2 spec-1) '2) + ((eql-specializer-flag spec-1) '1) ; is this engough? + ((eql-specializer-flag spec-2) '2) ; Beppe + ((member spec-1 (member spec-2 cpl)) '2) + ((member spec-2 (member spec-1 cpl)) '1) + ;; This will force an error in the caller + (t nil))))) (defun compute-g-f-spec-list (gf) (with-early-accessors (+standard-generic-function-slots+ - +eql-specializer-slots+ - +standard-method-slots+) + +eql-specializer-slots+ + +standard-method-slots+) (flet ((nupdate-spec-how-list (spec-how-list specializers gf) - ;; update the spec-how of the gfun - ;; computing the or of the previous value and the new one - (setf spec-how-list (or spec-how-list - (copy-list specializers))) - (do* ((l specializers (cdr l)) - (l2 spec-how-list (cdr l2)) - (spec-how) - (spec-how-old)) - ((null l)) - (setq spec-how (first l) spec-how-old (first l2)) - (setf (first l2) - (if (eql-specializer-flag spec-how) - (list* (eql-specializer-object spec-how) - (and (consp spec-how-old) spec-how-old)) - (if (consp spec-how-old) - spec-how-old - spec-how)))) - spec-how-list)) + ;; update the spec-how of the gfun + ;; computing the or of the previous value and the new one + (setf spec-how-list (or spec-how-list + (copy-list specializers))) + (do* ((l specializers (cdr l)) + (l2 spec-how-list (cdr l2)) + (spec-how) + (spec-how-old)) + ((null l)) + (setq spec-how (first l) spec-how-old (first l2)) + (setf (first l2) + (if (eql-specializer-flag spec-how) + (list* (eql-specializer-object spec-how) + (and (consp spec-how-old) spec-how-old)) + (if (consp spec-how-old) + spec-how-old + spec-how)))) + spec-how-list)) (let* ((spec-how-list nil) - (function nil) - (a-p-o (generic-function-argument-precedence-order gf))) - (dolist (method (generic-function-methods gf)) - (setf spec-how-list - (nupdate-spec-how-list spec-how-list (method-specializers method) gf))) - (setf (generic-function-spec-list gf) - (loop for type in spec-how-list - for i from 0 - when type collect (cons type i))) - (let* ((g-f-l-l (generic-function-lambda-list gf))) - (when (consp g-f-l-l) - (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t)))) - (unless (equal a-p-o required-arguments) - (setf function - (coerce `(lambda (%list) - (destructuring-bind ,required-arguments %list - (list ,@a-p-o))) - 'function)))))) - (setf (generic-function-a-p-o-function gf) function) - (si:clear-gfun-hash gf))))) + (function nil) + (a-p-o (generic-function-argument-precedence-order gf))) + (dolist (method (generic-function-methods gf)) + (setf spec-how-list + (nupdate-spec-how-list spec-how-list (method-specializers method) gf))) + (setf (generic-function-spec-list gf) + (loop for type in spec-how-list + for i from 0 + when type collect (cons type i))) + (let* ((g-f-l-l (generic-function-lambda-list gf))) + (when (consp g-f-l-l) + (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t)))) + (unless (equal a-p-o required-arguments) + (setf function + (coerce `(lambda (%list) + (destructuring-bind ,required-arguments %list + (list ,@a-p-o))) + 'function)))))) + (setf (generic-function-a-p-o-function gf) function) + (si:clear-gfun-hash gf))))) (defun print-object (object stream) (print-unreadable-object (object stream))) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 9dd18eb3c..a5253ea56 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -14,11 +14,11 @@ ;;; ---------------------------------------------------------------------- -(defparameter *method-size* 32) ; Size of methods hash tables +(defparameter *method-size* 32) ; Size of methods hash tables ;;; This holds fake methods created during bootstrap. ;;; It is an alist of: -;;; (method-name {method}+) +;;; (method-name {method}+) (defparameter *early-methods* nil) ;;; @@ -44,44 +44,44 @@ (defmacro defmethod (&whole whole name &rest args &environment env) (declare (notinline make-method-lambda)) (let* ((*print-length* 3) - (*print-depth* 2) - (qualifiers (loop while (and args (not (listp (first args)))) - collect (pop args))) - (specialized-lambda-list - (if args - (pop args) - (error "Illegal defmethod form: missing lambda list"))) - (body args)) + (*print-depth* 2) + (qualifiers (loop while (and args (not (listp (first args)))) + collect (pop args))) + (specialized-lambda-list + (if args + (pop args) + (error "Illegal defmethod form: missing lambda list"))) + (body args)) (multiple-value-bind (lambda-list required-parameters specializers) - (parse-specialized-lambda-list specialized-lambda-list) + (parse-specialized-lambda-list specialized-lambda-list) (multiple-value-bind (lambda-form declarations documentation) - (make-raw-lambda name lambda-list required-parameters specializers body env) - (let* ((generic-function (ensure-generic-function name)) - (method-class (generic-function-method-class generic-function)) - method) - (when *clos-booted* - (when (symbolp method-class) - (setf method-class (find-class method-class nil))) - (if method-class - (setf method (class-prototype method-class)) - (error "Cannot determine the method class for generic functions of type ~A" - (type-of generic-function)))) - (multiple-value-bind (fn-form options) - (make-method-lambda generic-function method lambda-form env) - (when documentation - (setf options (list* :documentation documentation options))) - (multiple-value-bind (wrapped-lambda wrapped-p) - (simplify-lambda name fn-form) - (unless wrapped-p - (error "Unable to unwrap function")) - (ext:register-with-pde - whole - `(install-method ',name ',qualifiers - ,(specializers-expression specializers) - ',lambda-list - ,(maybe-remove-block wrapped-lambda) - ,wrapped-p - ,@(mapcar #'si::maybe-quote options)))))))))) + (make-raw-lambda name lambda-list required-parameters specializers body env) + (let* ((generic-function (ensure-generic-function name)) + (method-class (generic-function-method-class generic-function)) + method) + (when *clos-booted* + (when (symbolp method-class) + (setf method-class (find-class method-class nil))) + (if method-class + (setf method (class-prototype method-class)) + (error "Cannot determine the method class for generic functions of type ~A" + (type-of generic-function)))) + (multiple-value-bind (fn-form options) + (make-method-lambda generic-function method lambda-form env) + (when documentation + (setf options (list* :documentation documentation options))) + (multiple-value-bind (wrapped-lambda wrapped-p) + (simplify-lambda name fn-form) + (unless wrapped-p + (error "Unable to unwrap function")) + (ext:register-with-pde + whole + `(install-method ',name ',qualifiers + ,(specializers-expression specializers) + ',lambda-list + ,(maybe-remove-block wrapped-lambda) + ,wrapped-p + ,@(mapcar #'si::maybe-quote options)))))))))) (defun specializers-expression (specializers) (declare (si::c-local)) @@ -93,47 +93,47 @@ ;; the value of constant symbols, which would not be EQL to the value of ;; those same constants when the code is reloaded. (list 'si::quasiquote - (loop for spec in specializers - collect (if (atom spec) - spec - `(eql ,(let ((value (second spec))) - (if (if (atom value) - (not (symbolp value)) - (eq (car value) 'quote)) - (ext:constant-form-value value) - (list 'si::unquote value)))))))) + (loop for spec in specializers + collect (if (atom spec) + spec + `(eql ,(let ((value (second spec))) + (if (if (atom value) + (not (symbolp value)) + (eq (car value) 'quote)) + (ext:constant-form-value value) + (list 'si::unquote value)))))))) (defun maybe-remove-block (method-lambda) (when (eq (first method-lambda) 'lambda) (multiple-value-bind (declarations body documentation) - (si::find-declarations (cddr method-lambda)) + (si::find-declarations (cddr method-lambda)) (let (block) - (when (and (null (rest body)) - (listp (setf block (first body))) - (eq (first block) 'block)) - (setf method-lambda `(ext:lambda-block ,(second block) ,(second method-lambda) - ,@declarations - ,@(cddr block))) - )))) + (when (and (null (rest body)) + (listp (setf block (first body))) + (eq (first block) 'block)) + (setf method-lambda `(ext:lambda-block ,(second block) ,(second method-lambda) + ,@declarations + ,@(cddr block))) + )))) method-lambda) (defun simplify-lambda (method-name fn-form) (let ((aux fn-form)) (if (and (eq (pop aux) 'lambda) - (equalp (pop aux) '(.combined-method-args. *next-methods*)) - (equalp (pop aux) '(declare (special .combined-method-args. *next-methods*))) - (null (rest aux)) - (= (length (setf aux (first aux))) 3) - (eq (first aux) 'apply) - (eq (third aux) '.combined-method-args.) - (listp (setf aux (second aux))) - (eq (first aux) 'lambda)) - (values aux t) - (values fn-form nil)))) + (equalp (pop aux) '(.combined-method-args. *next-methods*)) + (equalp (pop aux) '(declare (special .combined-method-args. *next-methods*))) + (null (rest aux)) + (= (length (setf aux (first aux))) 3) + (eq (first aux) 'apply) + (eq (third aux) '.combined-method-args.) + (listp (setf aux (second aux))) + (eq (first aux) 'lambda)) + (values aux t) + (values fn-form nil)))) (defun make-raw-lambda (name lambda-list required-parameters specializers body env) (declare (si::c-local) - (ignore env)) + (ignore env)) (multiple-value-bind (declarations real-body documentation) (sys::find-declarations body) ;; FIXME!! This deactivates the checking of keyword arguments @@ -143,73 +143,73 @@ ;; that check, either in the method itself so that it is done ;; incrementally, or in COMPUTE-EFFECTIVE-METHOD. (when (and (member '&key lambda-list) - (not (member '&allow-other-keys lambda-list))) + (not (member '&allow-other-keys lambda-list))) (let ((x (position '&aux lambda-list))) - (setf lambda-list - (append (subseq lambda-list 0 x) - '(&allow-other-keys) - (and x (subseq lambda-list x)) + (setf lambda-list + (append (subseq lambda-list 0 x) + '(&allow-other-keys) + (and x (subseq lambda-list x)) nil)))) (let* ((copied-variables '()) - (ignorable `(declare (ignorable ,@required-parameters))) - (class-declarations - (nconc (when *add-method-argument-declarations* - (loop for name in required-parameters - for type in specializers - when (and (not (eq type t)) (symbolp type)) - do (push `(,name ,name) copied-variables) and - nconc `((type ,type ,name) - (si::no-check-type ,name)))) - (list (list 'si::function-block-name name)) - (cdar declarations))) - (block `(block ,(si::function-block-name name) ,@real-body)) - (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; second of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ,@(and class-declarations `((declare ,@class-declarations))) - ,ignorable - ,(if copied-variables - `(let* ,copied-variables - ,ignorable - ,block) - block)))) + (ignorable `(declare (ignorable ,@required-parameters))) + (class-declarations + (nconc (when *add-method-argument-declarations* + (loop for name in required-parameters + for type in specializers + when (and (not (eq type t)) (symbolp type)) + do (push `(,name ,name) copied-variables) and + nconc `((type ,type ,name) + (si::no-check-type ,name)))) + (list (list 'si::function-block-name name)) + (cdar declarations))) + (block `(block ,(si::function-block-name name) ,@real-body)) + (method-lambda + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; second of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ,@(and class-declarations `((declare ,@class-declarations))) + ,ignorable + ,(if copied-variables + `(let* ,copied-variables + ,ignorable + ,block) + block)))) (values method-lambda declarations documentation)))) (defun make-method-lambda (gf method method-lambda env) (multiple-value-bind (call-next-method-p next-method-p-p in-closure-p) (walk-method-lambda method-lambda env) (values `(lambda (.combined-method-args. *next-methods*) - (declare (special .combined-method-args. *next-methods*)) - (apply ,(if in-closure-p - (add-call-next-method-closure method-lambda) - method-lambda) - .combined-method-args.)) - nil))) + (declare (special .combined-method-args. *next-methods*)) + (apply ,(if in-closure-p + (add-call-next-method-closure method-lambda) + method-lambda) + .combined-method-args.)) + nil))) (defun add-call-next-method-closure (method-lambda) (multiple-value-bind (declarations real-body documentation) (si::find-declarations (cddr method-lambda)) `(lambda ,(second method-lambda) (let* ((.closed-combined-method-args. - (if (listp .combined-method-args.) - .combined-method-args. - (apply #'list .combined-method-args.))) - (.next-methods. *next-methods*)) - (flet ((call-next-method (&rest args) - (unless .next-methods. - (error "No next method")) - (funcall (car .next-methods.) - (or args .closed-combined-method-args.) - (rest .next-methods.))) - (next-method-p () - .next-methods.)) - ,@real-body))))) + (if (listp .combined-method-args.) + .combined-method-args. + (apply #'list .combined-method-args.))) + (.next-methods. *next-methods*)) + (flet ((call-next-method (&rest args) + (unless .next-methods. + (error "No next method")) + (funcall (car .next-methods.) + (or args .closed-combined-method-args.) + (rest .next-methods.))) + (next-method-p () + .next-methods.)) + ,@real-body))))) (defun environment-contains-closure (env) ;; @@ -222,44 +222,44 @@ (declare (fixnum counter)) (dolist (item (car env)) (when (and (consp item) - (eq (first (the cons item)) 'si::function-boundary) - (> (incf counter) 1)) - (return t))))) + (eq (first (the cons item)) 'si::function-boundary) + (> (incf counter) 1)) + (return t))))) (defun walk-method-lambda (method-lambda env) (declare (si::c-local)) (let ((call-next-method-p nil) - (next-method-p-p nil) - (in-closure-p nil)) + (next-method-p-p nil) + (in-closure-p nil)) (flet ((code-walker (form env) - (unless (atom form) - (let ((name (first form))) - (case name - (CALL-NEXT-METHOD - (setf call-next-method-p - (or call-next-method-p T) - in-closure-p - (or in-closure-p (environment-contains-closure env)))) - (NEXT-METHOD-P - (setf next-method-p-p t - in-closure-p (or in-closure-p (environment-contains-closure env)))) - (FUNCTION - (when (eq (second form) 'CALL-NEXT-METHOD) - (setf in-closure-p t - call-next-method-p 'FUNCTION)) - (when (eq (second form) 'NEXT-METHOD-P) - (setf next-method-p-p 'FUNCTION - in-closure-p t)))))) - form)) + (unless (atom form) + (let ((name (first form))) + (case name + (CALL-NEXT-METHOD + (setf call-next-method-p + (or call-next-method-p T) + in-closure-p + (or in-closure-p (environment-contains-closure env)))) + (NEXT-METHOD-P + (setf next-method-p-p t + in-closure-p (or in-closure-p (environment-contains-closure env)))) + (FUNCTION + (when (eq (second form) 'CALL-NEXT-METHOD) + (setf in-closure-p t + call-next-method-p 'FUNCTION)) + (when (eq (second form) 'NEXT-METHOD-P) + (setf next-method-p-p 'FUNCTION + in-closure-p t)))))) + form)) (let ((si::*code-walker* #'code-walker)) - ;; Instead of (coerce method-lambda 'function) we use + ;; Instead of (coerce method-lambda 'function) we use ;; explicitely the bytecodes compiler with an environment, no ;; stepping, compiler-env-p = t and execute = nil, so that the ;; form does not get executed. (si::eval-with-env method-lambda env nil t t))) (values call-next-method-p - next-method-p-p - in-closure-p))) + next-method-p-p + in-closure-p))) ;;; ---------------------------------------------------------------------- ;;; parsing @@ -281,13 +281,13 @@ (error "~A cannot be a generic function specifier.~%~ It must be either a non-nil symbol or ~%~ a list whose car is setf and whose second is a non-nil symbol." - name)) + name)) (do ((qualifiers '())) - ((progn - (when (endp args) - (error "Illegal defmethod form: missing lambda-list")) - (listp (first args))) - (values name (nreverse qualifiers) (first args) (rest args))) + ((progn + (when (endp args) + (error "Illegal defmethod form: missing lambda-list")) + (listp (first args))) + (values name (nreverse qualifiers) (first args) (rest args))) (push (pop args) qualifiers)))) (defun implicit-generic-lambda (lambda-list) @@ -317,16 +317,16 @@ have disappeared." ;; list of required arguments. We use this list to extract the ;; specializers and build a lambda list without specializers. (do* ((arglist (rest (si::process-lambda-list specialized-lambda-list 'METHOD)) - (rest arglist)) - (lambda-list (copy-list specialized-lambda-list)) - (ll lambda-list (rest ll)) - (required-parameters '()) - (specializers '()) - arg variable specializer) + (rest arglist)) + (lambda-list (copy-list specialized-lambda-list)) + (ll lambda-list (rest ll)) + (required-parameters '()) + (specializers '()) + arg variable specializer) ((null arglist) - (values lambda-list - (nreverse required-parameters) - (nreverse specializers))) + (values lambda-list + (nreverse required-parameters) + (nreverse specializers))) (setf arg (first arglist)) (cond ;; Just a variable @@ -337,15 +337,15 @@ have disappeared." (si::simple-program-error "Syntax error in method specializer ~A" arg)) ;; Specializer is NIL ((null (setf variable (first arg) - specializer (second arg))) + specializer (second arg))) (si::simple-program-error - "NIL is not a valid specializer in a method lambda list")) + "NIL is not a valid specializer in a method lambda list")) ;; Specializer is a class name ((atom specializer)) ;; Specializer is (EQL value) ((and (eql (first specializer) 'EQL) - (cdr specializer) - (endp (cddr specializer)))) + (cdr specializer) + (endp (cddr specializer)))) ;; Otherwise, syntax error (t (si::simple-program-error "Syntax error in method specializer ~A" arg))) @@ -358,11 +358,11 @@ have disappeared." (do ((argscan arglist (cdr argscan)) (declist (when declarations (cdr declarations)))) ((or - (null argscan) - (member (first argscan) '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX))) + (null argscan) + (member (first argscan) '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX))) `(DECLARE ,@declist)) (when (listp (first argscan)) - (push `(TYPE ,(cadar argscan) ,(caar argscan)) declist)))) + (push `(TYPE ,(cadar argscan) ,(caar argscan)) declist)))) ;;; ---------------------------------------------------------------------- @@ -373,9 +373,9 @@ have disappeared." (si::process-lambda-list lambda-list t) (declare (ignore reqs opts rest key-flag)) (if allow-other-keys - 't - (loop for k in (rest keywords) by #'cddddr - collect k)))) + 't + (loop for k in (rest keywords) by #'cddddr + collect k)))) (defun make-method (method-class qualifiers specializers lambda-list fun options) (declare (ignore options)) @@ -383,14 +383,14 @@ have disappeared." ;; We choose the largest list of slots +standard-accessor-method-slots+ (method (if (si::instancep method-class) - method-class - (find-class method-class)) - :generic-function nil - :lambda-list lambda-list - :function fun - :specializers specializers - :qualifiers qualifiers - :keywords (compute-method-keywords lambda-list)) + method-class + (find-class method-class)) + :generic-function nil + :lambda-list lambda-list + :function fun + :specializers specializers + :qualifiers qualifiers + :keywords (compute-method-keywords lambda-list)) method)) ;;; early version used during bootstrap @@ -401,18 +401,18 @@ have disappeared." (defun add-method (gf method) (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+ +standard-class-slots+) (let* ((name (slot-value gf 'name)) - (method-entry (assoc name *early-methods*))) + (method-entry (assoc name *early-methods*))) (unless method-entry - (setq method-entry (list name)) - (push method-entry *early-methods*)) + (setq method-entry (list name)) + (push method-entry *early-methods*)) (push method (cdr method-entry)) (push method (generic-function-methods gf)) (setf (method-generic-function method) gf) (unless (si::sl-boundp (generic-function-lambda-list gf)) - (setf (generic-function-lambda-list gf) (implicit-generic-lambda + (setf (generic-function-lambda-list gf) (implicit-generic-lambda (method-lambda-list method))) - (setf (generic-function-argument-precedence-order gf) - (rest (si::process-lambda-list (method-lambda-list method) t)))) + (setf (generic-function-argument-precedence-order gf) + (rest (si::process-lambda-list (method-lambda-list method) t)))) (compute-g-f-spec-list gf) (set-generic-function-dispatch gf) method))) @@ -420,41 +420,41 @@ have disappeared." (defun find-method (gf qualifiers specializers &optional (errorp t)) (declare (notinline method-qualifiers)) (flet ((filter-specializer (name) - (cond ((typep name 'specializer) - name) - ((atom name) - (let ((class (find-class name nil))) - (unless class - (error "~A is not a valid specializer name" name)) - class)) - ((and (eq (first name) 'EQL) - (null (cddr name))) - (cdr name)) - (t - (error "~A is not a valid specializer name" name)))) - (specializer= (cons-or-class specializer) - (if (consp cons-or-class) - (and (eql-specializer-flag specializer) - (eql (car cons-or-class) - (eql-specializer-object specializer))) - (eq cons-or-class specializer)))) + (cond ((typep name 'specializer) + name) + ((atom name) + (let ((class (find-class name nil))) + (unless class + (error "~A is not a valid specializer name" name)) + class)) + ((and (eq (first name) 'EQL) + (null (cddr name))) + (cdr name)) + (t + (error "~A is not a valid specializer name" name)))) + (specializer= (cons-or-class specializer) + (if (consp cons-or-class) + (and (eql-specializer-flag specializer) + (eql (car cons-or-class) + (eql-specializer-object specializer))) + (eq cons-or-class specializer)))) (when (/= (length specializers) - (length (generic-function-argument-precedence-order gf))) + (length (generic-function-argument-precedence-order gf))) (error "The specializers list~%~A~%does not match the number of required arguments in ~A" specializers (generic-function-name gf))) (loop with specializers = (mapcar #'filter-specializer specializers) for method in (generic-function-methods gf) when (and (equal qualifiers (method-qualifiers method)) - (every #'specializer= specializers (method-specializers method))) + (every #'specializer= specializers (method-specializers method))) do (return-from find-method method)) ;; If we did not find any matching method, then the list of ;; specializers might have the wrong size and we must signal ;; an error. (when errorp (error "There is no method on the generic function ~S that agrees on qualifiers ~S and specializers ~S" - (generic-function-name gf) - qualifiers specializers))) + (generic-function-name gf) + qualifiers specializers))) nil) ;;; ---------------------------------------------------------------------- @@ -462,10 +462,10 @@ have disappeared." (defmacro with-accessors (slot-accessor-pairs instance-form &body body) (let* ((temp (gensym)) - (accessors (do ((scan slot-accessor-pairs (cdr scan)) - (res)) - ((null scan) (nreverse res)) - (push `(,(caar scan) (,(cadar scan) ,temp)) res)))) + (accessors (do ((scan slot-accessor-pairs (cdr scan)) + (res)) + ((null scan) (nreverse res)) + (push `(,(caar scan) (,(cadar scan) ,temp)) res)))) `(let ((,temp ,instance-form)) (symbol-macrolet ,accessors ,@body)))) diff --git a/src/clos/package.lsp b/src/clos/package.lsp index 59a612c56..66948ac04 100644 --- a/src/clos/package.lsp +++ b/src/clos/package.lsp @@ -13,5 +13,5 @@ (defpackage "CLOS" (:use "CL" "EXT") (:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" - "SIMPLE-PROGRAM-ERROR")) + "SIMPLE-PROGRAM-ERROR")) diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 735b0c95d..013859098 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -22,20 +22,20 @@ (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) (do* ((class (class-of object)) - (initialization (list 'progn)) - (slots (class-slots class) (cdr slots))) + (initialization (list 'progn)) + (slots (class-slots class) (cdr slots))) ((endp slots) (values `(allocate-instance ,class) (nreverse initialization))) (let* ((slot (first slots)) - (slot-name (slot-definition-name slot))) + (slot-name (slot-definition-name slot))) (when (or (and (null slot-names) - (eq (slot-definition-allocation slot) :instance)) - (member slot-name slot-names)) - (push (if (slot-boundp object slot-name) - `(setf (slot-value ,object ',slot-name) - ',(slot-value object slot-name)) - `(slot-makunbound ,object ',slot-name)) - initialization))))) + (eq (slot-definition-allocation slot) :instance)) + (member slot-name slot-names)) + (push (if (slot-boundp object slot-name) + `(setf (slot-value ,object ',slot-name) + ',(slot-value object slot-name)) + `(slot-makunbound ,object ',slot-name)) + initialization))))) (defun need-to-make-load-form-p (object env) "Return T if the object cannot be externalized using the lisp @@ -44,28 +44,28 @@ printer and we should rather use MAKE-LOAD-FORM." (let ((*load-form-cache* nil)) (declare (special *load-form-cache*)) (labels ((recursive-test (object) - (loop - ;; For simple, atomic objects we just return NIL. There is no need to - ;; call MAKE-LOAD-FORM on them - (when (typep object '(or character number symbol pathname string bit-vector)) - (return nil)) - ;; For complex objects we set up a cache and run through the - ;; objects content looking for data that might require - ;; MAKE-LOAD-FORM to be externalized. The cache is used to - ;; solve the problem of circularity and of EQ references. - (unless *load-form-cache* - (setf *load-form-cache* (make-hash-table :size 128 :test #'eq))) - (when (gethash object *load-form-cache*) - (return nil)) - (setf (gethash object *load-form-cache*) t) - (cond ((arrayp object) - (unless (subtypep (array-element-type object) '(or character number)) - (dotimes (i (array-total-size object)) - (recursive-test (row-major-aref object i)))) - (return nil)) - ((consp object) - (recursive-test (car object)) - (setf object (rest object))) + (loop + ;; For simple, atomic objects we just return NIL. There is no need to + ;; call MAKE-LOAD-FORM on them + (when (typep object '(or character number symbol pathname string bit-vector)) + (return nil)) + ;; For complex objects we set up a cache and run through the + ;; objects content looking for data that might require + ;; MAKE-LOAD-FORM to be externalized. The cache is used to + ;; solve the problem of circularity and of EQ references. + (unless *load-form-cache* + (setf *load-form-cache* (make-hash-table :size 128 :test #'eq))) + (when (gethash object *load-form-cache*) + (return nil)) + (setf (gethash object *load-form-cache*) t) + (cond ((arrayp object) + (unless (subtypep (array-element-type object) '(or character number)) + (dotimes (i (array-total-size object)) + (recursive-test (row-major-aref object i)))) + (return nil)) + ((consp object) + (recursive-test (car object)) + (setf object (rest object))) ((compiled-function-p object) (multiple-value-bind (lex code data name) (si::bc-split object) @@ -76,17 +76,17 @@ printer and we should rather use MAKE-LOAD-FORM." (recursive-test name)) (throw 'need-to-make-load-form t)) (setf object data))) - (t - (throw 'need-to-make-load-form t)))))) + (t + (throw 'need-to-make-load-form t)))))) (catch 'need-to-make-load-form - (recursive-test object) - nil)))) + (recursive-test object) + nil)))) (defmethod make-load-form ((object t) &optional env) (flet ((maybe-quote (object) - (if (or (consp object) (symbolp object)) - (list 'quote object) - object))) + (if (or (consp object) (symbolp object)) + (list 'quote object) + object))) (unless (need-to-make-load-form-p object env) (return-from make-load-form (maybe-quote object))) (typecase object @@ -101,39 +101,39 @@ printer and we should rather use MAKE-LOAD-FORM." ,(make-load-form name env))))) (array (let ((init-forms '())) - (values `(make-array ',(array-dimensions object) - :element-type ',(array-element-type object) - :adjustable ',(adjustable-array-p object) - :initial-contents - ',(loop for i from 0 below (array-total-size object) - collect (let ((x (row-major-aref object i))) - (if (need-to-make-load-form-p x env) - (progn (push `(setf (row-major-aref ,object ,i) ',x) - init-forms) - 0) - x)))) - (and init-forms `(progn ,@init-forms))))) + (values `(make-array ',(array-dimensions object) + :element-type ',(array-element-type object) + :adjustable ',(adjustable-array-p object) + :initial-contents + ',(loop for i from 0 below (array-total-size object) + collect (let ((x (row-major-aref object i))) + (if (need-to-make-load-form-p x env) + (progn (push `(setf (row-major-aref ,object ,i) ',x) + init-forms) + 0) + x)))) + (and init-forms `(progn ,@init-forms))))) (cons (values `(cons ,(maybe-quote (car object)) nil) - (and (rest object) `(rplacd ,(maybe-quote object) - ,(maybe-quote (cdr object)))))) + (and (rest object) `(rplacd ,(maybe-quote object) + ,(maybe-quote (cdr object)))))) (hash-table (let* ((content (ext:hash-table-content object)) - (make-form `(make-hash-table - :size ,(hash-table-size object) - :rehash-size ,(hash-table-rehash-size object) - :rehash-threshold ,(hash-table-rehash-threshold object) - :test ',(hash-table-test object)))) - (if (need-to-make-load-form-p content env) - (values - make-form - `(dolist (i ',(loop for key being each hash-key in object - using (hash-value obj) - collect (cons key obj))) - (setf (gethash (car i) ,object) (cdr i)))) - (values - `(ext:hash-table-fill ,make-form ',content) - nil)))) + (make-form `(make-hash-table + :size ,(hash-table-size object) + :rehash-size ,(hash-table-rehash-size object) + :rehash-threshold ,(hash-table-rehash-threshold object) + :test ',(hash-table-test object)))) + (if (need-to-make-load-form-p content env) + (values + make-form + `(dolist (i ',(loop for key being each hash-key in object + using (hash-value obj) + collect (cons key obj))) + (setf (gethash (car i) ,object) (cdr i)))) + (values + `(ext:hash-table-fill ,make-form ',content) + nil)))) (t (no-make-load-form object))))) @@ -149,14 +149,14 @@ printer and we should rather use MAKE-LOAD-FORM." (defun no-make-load-form (object) (declare (si::c-local)) (error "No adequate specialization of MAKE-LOAD-FORM for an object of type" - (type-of object))) + (type-of object))) (defmethod make-load-form ((class class) &optional environment) (declare (ignore environment)) (let ((name (class-name class))) (if (and name (eq (find-class name) class)) - `(find-class ',name) - (error "Cannot externalize anonymous class ~A" class)))) + `(find-class ',name) + (error "Cannot externalize anonymous class ~A" class)))) (defmethod make-load-form ((package package) &optional environment) (declare (ignore environment)) @@ -173,14 +173,14 @@ printer and we should rather use MAKE-LOAD-FORM." (print-unreadable-object (instance stream) (let ((*package* (find-package "CL"))) (format stream "a ~S" - (class-name (si:instance-class instance))))) + (class-name (si:instance-class instance))))) instance) (defmethod print-object ((class class) stream) (print-unreadable-object (class stream) (let ((*package* (find-package "CL"))) (format stream "The ~S ~S" - (class-name (si:instance-class class)) (class-name class)))) + (class-name (si:instance-class class)) (class-name class)))) class) (defmethod print-object ((gf standard-generic-function) stream) @@ -191,11 +191,11 @@ printer and we should rather use MAKE-LOAD-FORM." (defmethod print-object ((m standard-method) stream) (print-unreadable-object (m stream :type t) (format stream "~A ~A" - (let ((gf (method-generic-function m))) - (if gf - (generic-function-name gf) - 'UNNAMED)) - (method-specializers m))) + (let ((gf (method-generic-function m))) + (if gf + (generic-function-name gf) + 'UNNAMED)) + (method-specializers m))) m) (defun ext::float-nan-string (x) @@ -238,46 +238,46 @@ printer and we should rather use MAKE-LOAD-FORM." (defmethod describe-object ((obj t) (stream t)) (let* ((class (class-of obj)) - (slotds (class-slots class))) + (slotds (class-slots class))) (format stream "~%~A is an instance of class ~A" - obj (class-name class)) + obj (class-name class)) (do ((scan slotds (cdr scan)) - (i 0 (1+ i)) - (sv)) - ((null scan)) - (declare (fixnum i)) - (setq sv (si:instance-ref obj i)) - (print (slot-definition-name (car scan)) stream) (princ ": " stream) - (if (si:sl-boundp sv) - (prin1 sv stream) - (prin1 "Unbound" stream)))) + (i 0 (1+ i)) + (sv)) + ((null scan)) + (declare (fixnum i)) + (setq sv (si:instance-ref obj i)) + (print (slot-definition-name (car scan)) stream) (princ ": " stream) + (if (si:sl-boundp sv) + (prin1 sv stream) + (prin1 "Unbound" stream)))) obj) (defmethod describe-object ((obj class) (stream t)) (let* ((class (si:instance-class obj)) - (slotds (class-slots class))) + (slotds (class-slots class))) (format stream "~%~A is an instance of class ~A" - obj (class-name class)) + obj (class-name class)) (do ((scan slotds (cdr scan)) - (i 0 (1+ i)) - (sv)) - ((null scan)) - (declare (fixnum i)) - (print (slot-definition-name (car scan)) stream) (princ ": " stream) - (case (slot-definition-name (car scan)) - ((superiors inferiors) - (princ "(" stream) - (do* ((scan (si:instance-ref obj i) (cdr scan)) - (e (car scan) (car scan))) - ((null scan)) - (prin1 (class-name e) stream) - (when (cdr scan) (princ " " stream))) - (princ ")" stream)) - (otherwise - (setq sv (si:instance-ref obj i)) - (if (si:sl-boundp sv) - (prin1 sv stream) - (prin1 "Unbound" stream)))))) + (i 0 (1+ i)) + (sv)) + ((null scan)) + (declare (fixnum i)) + (print (slot-definition-name (car scan)) stream) (princ ": " stream) + (case (slot-definition-name (car scan)) + ((superiors inferiors) + (princ "(" stream) + (do* ((scan (si:instance-ref obj i) (cdr scan)) + (e (car scan) (car scan))) + ((null scan)) + (prin1 (class-name e) stream) + (when (cdr scan) (princ " " stream))) + (princ ")" stream)) + (otherwise + (setq sv (si:instance-ref obj i)) + (if (si:sl-boundp sv) + (prin1 sv stream) + (prin1 "Unbound" stream)))))) obj) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 08bc7fc09..fa97c164e 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -19,24 +19,24 @@ ;;; (defun make-simple-slotd (class - &key name (initform +initform-unsupplied+) initfunction - (type 'T) (allocation :instance) - initargs readers writers documentation location) + &key name (initform +initform-unsupplied+) initfunction + (type 'T) (allocation :instance) + initargs readers writers documentation location) (when (and (eq allocation :class) - (functionp initfunction)) + (functionp initfunction)) (setf initfunction (constantly (funcall initfunction)))) (with-early-make-instance +slot-definition-slots+ (slotd class - :name name - :initform initform - :initfunction (if (listp initfunction) (eval initfunction) initfunction) - :type type - :allocation allocation - :initargs initargs - :readers readers - :writers writers - :documentation documentation - :location location) + :name name + :initform initform + :initfunction (if (listp initfunction) (eval initfunction) initfunction) + :type type + :allocation allocation + :initargs initargs + :readers readers + :writers writers + :documentation documentation + :location location) slotd)) (defun freeze-class-slot-initfunction (slotd) @@ -52,15 +52,15 @@ (setf slotd (freeze-class-slot-initfunction slotd)) (if (find-class 'slot-definition nil) (apply #'make-instance - (apply #'direct-slot-definition-class class - (freeze-class-slot-initfunction slotd)) - slotd) + (apply #'direct-slot-definition-class class + (freeze-class-slot-initfunction slotd)) + slotd) (apply #'make-simple-slotd class slotd))) (defun direct-slot-to-canonical-slot (slotd) (list . #.(loop for (name . rest) in +slot-definition-slots+ - collect (getf rest :initarg) - collect `(,(getf rest :accessor) slotd)))) + collect (getf rest :initarg) + collect `(,(getf rest :accessor) slotd)))) ;;; ---------------------------------------------------------------------- ;;; @@ -87,55 +87,55 @@ (declare (si::c-local)) (if (symbolp slot) (list* :name slot - (when full (list :initform '+INITFORM-UNSUPPLIED+ :initfunction nil - :initargs nil :readers nil :writers nil - :allocation :instance :documentation nil - :type 'T))) + (when full (list :initform '+INITFORM-UNSUPPLIED+ :initfunction nil + :initargs nil :readers nil :writers nil + :allocation :instance :documentation nil + :type 'T))) (do* ((output (parse-slot (first slot) full)) - (options (rest slot)) - (value nil) - (extra nil)) - ((null options) - (nconc output extra)) - (let ((option (pop options))) - (when (endp options) - (si::simple-program-error - "In the slot description ~S,~%the option ~S is missing an argument" - slot option)) - (let ((value (pop options))) - (when (and (member option '(:allocation :initform :type :documentation)) - (getf options option)) - (si::simple-program-error - "In the slot description ~S,~%the option ~S is duplicated" - slot option)) - (case option - (:initarg (push value (getf output :initargs))) - (:initform (setf (getf output :initform) value - (getf output :initfunction) - (make-function-initform value))) - (:accessor (push value (getf output :readers)) - (push `(setf ,value) (getf output :writers))) - (:reader (push value (getf output :readers))) - (:writer (push value (getf output :writers))) - (:allocation (setf (getf output :allocation) value)) - (:type (setf (getf output :type) value)) - (:documentation (setf (getf output :documentation) value)) - (otherwise (if (or (getf extra option) - (getf options option)) - (push value (getf extra option)) - (setf (getf extra option) value))))))))) + (options (rest slot)) + (value nil) + (extra nil)) + ((null options) + (nconc output extra)) + (let ((option (pop options))) + (when (endp options) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is missing an argument" + slot option)) + (let ((value (pop options))) + (when (and (member option '(:allocation :initform :type :documentation)) + (getf options option)) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is duplicated" + slot option)) + (case option + (:initarg (push value (getf output :initargs))) + (:initform (setf (getf output :initform) value + (getf output :initfunction) + (make-function-initform value))) + (:accessor (push value (getf output :readers)) + (push `(setf ,value) (getf output :writers))) + (:reader (push value (getf output :readers))) + (:writer (push value (getf output :writers))) + (:allocation (setf (getf output :allocation) value)) + (:type (setf (getf output :type) value)) + (:documentation (setf (getf output :documentation) value)) + (otherwise (if (or (getf extra option) + (getf options option)) + (push value (getf extra option)) + (setf (getf extra option) value))))))))) (defun parse-slots (slots) (do ((scan slots (cdr scan)) (collect)) ((null scan) (nreverse collect)) (let* ((slotd (parse-slot (first scan))) - (name (getf slotd :name))) + (name (getf slotd :name))) (dolist (other-slotd collect) - (when (eq name (getf other-slotd :name)) - (si::simple-program-error - "A definition for the slot ~S appeared twice in a DEFCLASS form" - name))) + (when (eq name (getf other-slotd :name)) + (si::simple-program-error + "A definition for the slot ~S appeared twice in a DEFCLASS form" + name))) (push slotd collect)))) ;;; ---------------------------------------------------------------------- diff --git a/src/clos/slotvalue.lsp b/src/clos/slotvalue.lsp index e61621212..669509b3c 100644 --- a/src/clos/slotvalue.lsp +++ b/src/clos/slotvalue.lsp @@ -19,19 +19,19 @@ (defun slot-makunbound (self slot-name) (let* ((class (class-of self)) - (slotd (find-slot-definition class slot-name))) + (slotd (find-slot-definition class slot-name))) (if slotd - (slot-makunbound-using-class class self slotd) - (slot-missing class self slot-name 'SLOT-MAKUNBOUND)) + (slot-makunbound-using-class class self slotd) + (slot-missing class self slot-name 'SLOT-MAKUNBOUND)) self)) (defmethod slot-value-using-class ((class std-class) self slotd) (declare (ignore class)) (let* ((location (slot-definition-location slotd)) - (value (standard-instance-access self location))) + (value (standard-instance-access self location))) (if (si:sl-boundp value) - value - (values (slot-unbound class self (slot-definition-name slotd)))))) + value + (values (slot-unbound class self (slot-definition-name slotd)))))) (defmethod slot-boundp-using-class ((class std-class) self slotd) (declare (ignore class)) @@ -51,7 +51,7 @@ ;;; (defmethod slot-missing ((class t) object slot-name operation - &optional new-value) + &optional new-value) (declare (ignore operation new-value class)) (error "~A is not a slot of ~A" slot-name object)) @@ -64,8 +64,8 @@ (defmethod slot-unbound ((class null) object slot-index) (declare (ignore class)) (let* ((class (class-of object)) - (slotd (find slot-index (slot-value class 'slots) - :key #'slot-definition-location))) + (slotd (find slot-index (slot-value class 'slots) + :key #'slot-definition-location))) (values (slot-unbound class object (slot-definition-name slotd))))) ;;; diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 2c628b7cb..b3c6579f8 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -21,7 +21,7 @@ (defmethod reinitialize-instance ((instance T) &rest initargs) (check-initargs (class-of instance) initargs - (valid-keywords-from-methods + (valid-keywords-from-methods (compute-applicable-methods #'reinitialize-instance (list instance)) (compute-applicable-methods @@ -53,30 +53,30 @@ ;; initialize-instance slots (dolist (slotd (class-slots class)) (let* ((slot-initargs (slot-definition-initargs slotd)) - (slot-name (slot-definition-name slotd))) - (or - ;; Try to initialize the slot from one of the initargs. - (do ((l initargs) initarg val) - ((null l) nil) - (setf initarg (pop l)) - (when (endp l) - (simple-program-error "Wrong number of keyword arguments for SHARED-INITIALIZE, ~A" - initargs)) - (unless (symbolp initarg) - (simple-program-error "Not a valid initarg: ~A" initarg)) - (setf val (pop l)) - (when (member initarg slot-initargs :test #'eq) - (setf (slot-value instance slot-name) val) - (return t))) - ;; Try to initialize the slot from its initform. - (when (and slot-names - (or (eq slot-names 'T) - (member slot-name slot-names)) - (not (slot-boundp instance slot-name))) - (let ((initfun (slot-definition-initfunction slotd))) - (when initfun - (setf (slot-value instance slot-name) (funcall initfun)))))) - ))) + (slot-name (slot-definition-name slotd))) + (or + ;; Try to initialize the slot from one of the initargs. + (do ((l initargs) initarg val) + ((null l) nil) + (setf initarg (pop l)) + (when (endp l) + (simple-program-error "Wrong number of keyword arguments for SHARED-INITIALIZE, ~A" + initargs)) + (unless (symbolp initarg) + (simple-program-error "Not a valid initarg: ~A" initarg)) + (setf val (pop l)) + (when (member initarg slot-initargs :test #'eq) + (setf (slot-value instance slot-name) val) + (return t))) + ;; Try to initialize the slot from its initform. + (when (and slot-names + (or (eq slot-names 'T) + (member slot-name slot-names)) + (not (slot-boundp instance slot-name))) + (let ((initfun (slot-definition-initfunction slotd))) + (when initfun + (setf (slot-value instance slot-name) (funcall initfun)))))) + ))) instance) ;;; ---------------------------------------------------------------------- @@ -89,9 +89,9 @@ with num-slots = 0 when (eq (slot-definition-allocation slotd) :instance) do (let ((new-loc (safe-slot-definition-location slotd))) - (incf num-slots) - (when (and new-loc (> new-loc last-location)) - (setf last-location new-loc))) + (incf num-slots) + (when (and new-loc (> new-loc last-location)) + (setf last-location new-loc))) finally (return (max num-slots (1+ last-location))))) (defmethod allocate-instance ((class class) &rest initargs) @@ -112,8 +112,8 @@ ;; (Paul Dietz's ANSI test suite, test CLASS-24.4) (setf initargs (add-default-initargs class initargs)) (let ((keywords (if (slot-boundp class 'valid-initargs) - (class-valid-initargs class) - (precompute-valid-initarg-keywords class)))) + (class-valid-initargs class) + (precompute-valid-initarg-keywords class)))) (check-initargs class initargs nil (class-slots class) keywords)) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) @@ -166,8 +166,8 @@ ;; convert the slots from lists to direct slots (apply #'call-next-method class :direct-slots - (loop for s in direct-slots - collect (canonical-slot-to-direct-slot class s)) + (loop for s in direct-slots + collect (canonical-slot-to-direct-slot class s)) initargs) (finalize-unless-forward class) class) @@ -175,12 +175,12 @@ (defmethod shared-initialize ((class class) slot-names &rest initargs &key direct-superclasses) ;; verify that the inheritance list makes sense (let* ((class (apply #'call-next-method class slot-names - :direct-superclasses - (if (slot-boundp class 'direct-superclasses) - (slot-value class 'direct-superclasses) - nil) - initargs)) - (direct-superclasses (check-direct-superclasses class direct-superclasses))) + :direct-superclasses + (if (slot-boundp class 'direct-superclasses) + (slot-value class 'direct-superclasses) + nil) + initargs)) + (direct-superclasses (check-direct-superclasses class direct-superclasses))) (loop for c in (class-direct-superclasses class) unless (member c direct-superclasses :test #'eq) do (remove-direct-subclass c class)) @@ -215,7 +215,7 @@ sealedp) (declare (ignore initargs slot-names)) (setf (slot-value class 'optimize-slot-access) (first optimize-slot-access) - (slot-value class 'sealedp) (and sealedp t)) + (slot-value class 'sealedp) (and sealedp t)) (setf class (call-next-method)) (update-dependents class initargs) class) @@ -225,22 +225,22 @@ (defmethod remove-direct-subclass ((parent class) child) (setf (class-direct-subclasses parent) - (remove child (class-direct-subclasses parent)))) + (remove child (class-direct-subclasses parent)))) (defun check-direct-superclasses (class supplied-superclasses) (if supplied-superclasses (loop for superclass in supplied-superclasses - ;; Until we process streams.lsp there are some invalid combinations - ;; using built-in-class, which here we simply ignore. - unless (or (validate-superclass class superclass) - (not (eq *clos-booted* T))) - do (error "Class ~A is not a valid superclass for ~A" superclass class)) + ;; Until we process streams.lsp there are some invalid combinations + ;; using built-in-class, which here we simply ignore. + unless (or (validate-superclass class superclass) + (not (eq *clos-booted* T))) + do (error "Class ~A is not a valid superclass for ~A" superclass class)) (setf supplied-superclasses - (list (find-class (typecase class - (STANDARD-CLASS 'STANDARD-OBJECT) - (STRUCTURE-CLASS 'STRUCTURE-OBJECT) - (FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT) - (otherwise (error "No :DIRECT-SUPERCLASS ~ + (list (find-class (typecase class + (STANDARD-CLASS 'STANDARD-OBJECT) + (STRUCTURE-CLASS 'STRUCTURE-OBJECT) + (FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT) + (otherwise (error "No :DIRECT-SUPERCLASS ~ argument was supplied for metaclass ~S." (class-of class)))))))) ;; FIXME!!! Here should come the invocation of VALIDATE-SUPERCLASS! ;; FIXME!!! We should check that structures and standard objects are @@ -251,11 +251,11 @@ argument was supplied for metaclass ~S." (class-of class)))))))) (defmethod validate-superclass ((class class) (superclass class)) (or (eq superclass +the-t-class+) (let ((c1 (class-of class)) - (c2 (class-of superclass))) - (or (eq c1 c2) - (and (eq c1 +the-standard-class+) (eq c2 +the-funcallable-standard-class+)) - (and (eq c2 +the-standard-class+) (eq c1 +the-funcallable-standard-class+)) - )) + (c2 (class-of superclass))) + (or (eq c1 c2) + (and (eq c1 +the-standard-class+) (eq c2 +the-funcallable-standard-class+)) + (and (eq c2 +the-standard-class+) (eq c1 +the-funcallable-standard-class+)) + )) (forward-referenced-class-p superclass) )) @@ -279,9 +279,9 @@ argument was supplied for metaclass ~S." (class-of class)))))))) ;; (let ((x (find-if #'forward-referenced-class-p (rest cpl)))) (when x - (error "Cannot finish building the class~% ~A~%~ + (error "Cannot finish building the class~% ~A~%~ because it contains a reference to the undefined class~% ~A" - (class-name class) (class-name x)))) + (class-name class) (class-name x)))) ;; ;; ... and in the second case we just finalize the top-most class ;; which is not yet finalized and rely on the fact that this @@ -289,51 +289,51 @@ because it contains a reference to the undefined class~% ~A" ;; (let ((x (find-if-not #'class-finalized-p cpl :from-end t))) (unless (or (null x) (eq x class)) - (return-from finalize-inheritance - (finalize-inheritance x)))) + (return-from finalize-inheritance + (finalize-inheritance x)))) (setf (class-precedence-list class) cpl) (let ((slots (compute-slots class))) (setf (class-slots class) slots - (class-size class) (compute-instance-size slots) - (class-default-initargs class) (compute-default-initargs class) - (class-finalized-p class) t)) + (class-size class) (compute-instance-size slots) + (class-default-initargs class) (compute-default-initargs class) + (class-finalized-p class) t)) ;; ;; When a class is sealed we rewrite the list of direct slots to fix ;; their locations. This may imply adding _new_ direct slots. ;; (when (class-sealedp class) (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class)))) - (all-slots (class-slots class))) - ;; - ;; We first search all slots that belonged to unsealed classes and which - ;; therefore have no fixed position. - ;; - (loop for c in cpl - do (loop for slotd in (class-direct-slots c) - when (safe-slot-definition-location slotd) - do (setf free-slots (delete (slot-definition-name slotd) free-slots)))) - ;; - ;; We now copy the locations of the effective slots in this class to - ;; the class direct slots. - ;; - (loop for slotd in (class-direct-slots class) - do (let* ((name (slot-definition-name slotd)) - (other-slotd (find name all-slots :key #'slot-definition-name))) - (setf (slot-definition-location slotd) - (slot-definition-location other-slotd) - free-slots (delete name free-slots)))) - ;; - ;; And finally we add one direct slot for each inherited slot that did - ;; not have a fixed location. - ;; - (loop for name in free-slots - with direct-slots = (class-direct-slots class) - do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name)) - (def (direct-slot-to-canonical-slot effective-slotd))) - (push (apply #'make-instance (direct-slot-definition-class class def) - def) - direct-slots)) - finally (setf (class-direct-slots class) direct-slots)))) + (all-slots (class-slots class))) + ;; + ;; We first search all slots that belonged to unsealed classes and which + ;; therefore have no fixed position. + ;; + (loop for c in cpl + do (loop for slotd in (class-direct-slots c) + when (safe-slot-definition-location slotd) + do (setf free-slots (delete (slot-definition-name slotd) free-slots)))) + ;; + ;; We now copy the locations of the effective slots in this class to + ;; the class direct slots. + ;; + (loop for slotd in (class-direct-slots class) + do (let* ((name (slot-definition-name slotd)) + (other-slotd (find name all-slots :key #'slot-definition-name))) + (setf (slot-definition-location slotd) + (slot-definition-location other-slotd) + free-slots (delete name free-slots)))) + ;; + ;; And finally we add one direct slot for each inherited slot that did + ;; not have a fixed location. + ;; + (loop for name in free-slots + with direct-slots = (class-direct-slots class) + do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name)) + (def (direct-slot-to-canonical-slot effective-slotd))) + (push (apply #'make-instance (direct-slot-definition-class class def) + def) + direct-slots)) + finally (setf (class-direct-slots class) direct-slots)))) ;; ;; This is not really needed, because when we modify the list of slots ;; all instances automatically become obsolete (See change.lsp) @@ -374,28 +374,28 @@ because it contains a reference to the undefined class~% ~A" ;; whenever possible, in the same position as in C1. ;; (do* ((all-slots (mapappend #'class-direct-slots (reverse (class-precedence-list class)))) - (all-names (nreverse (mapcar #'slot-definition-name all-slots))) - (output '()) - (scan all-names (cdr scan))) + (all-names (nreverse (mapcar #'slot-definition-name all-slots))) + (output '()) + (scan all-names (cdr scan))) ((endp scan) output) (let ((name (first scan))) (unless (find name (rest scan)) - (push (compute-effective-slot-definition - class name (delete name (reverse all-slots) :key #'slot-definition-name - :test-not #'eq)) - output))))) + (push (compute-effective-slot-definition + class name (delete name (reverse all-slots) :key #'slot-definition-name + :test-not #'eq)) + output))))) (defun slot-definition-to-plist (slotd) (list :name (slot-definition-name slotd) - :initform (slot-definition-initform slotd) - :initfunction (slot-definition-initfunction slotd) - :type (slot-definition-type slotd) - :allocation (slot-definition-allocation slotd) - :initargs (slot-definition-initargs slotd) - :readers (slot-definition-readers slotd) - :writers (slot-definition-writers slotd) - :documentation (slot-definition-documentation slotd) - :location (slot-definition-location slotd))) + :initform (slot-definition-initform slotd) + :initfunction (slot-definition-initfunction slotd) + :type (slot-definition-type slotd) + :allocation (slot-definition-allocation slotd) + :initargs (slot-definition-initargs slotd) + :readers (slot-definition-readers slotd) + :writers (slot-definition-writers slotd) + :documentation (slot-definition-documentation slotd) + :location (slot-definition-location slotd))) (defun safe-slot-definition-location (slotd &optional default) (if (or (listp slotd) (slot-boundp slotd 'location)) @@ -404,54 +404,54 @@ because it contains a reference to the undefined class~% ~A" (defmethod compute-effective-slot-definition ((class class) name direct-slots) (flet ((direct-to-effective (old-slot) - (if (consp old-slot) - (copy-list old-slot) - (let ((initargs (slot-definition-to-plist old-slot))) - (apply #'make-instance - (apply #'effective-slot-definition-class class initargs) - initargs)))) - (combine-slotds (new-slotd old-slotd) - (let* ((new-type (slot-definition-type new-slotd)) - (old-type (slot-definition-type old-slotd)) - (loc1 (safe-slot-definition-location new-slotd)) - (loc2 (safe-slot-definition-location old-slotd))) - (when loc2 - (if loc1 - (unless (eql loc1 loc2) - (error 'simple-error - :format-control "You have specified two conflicting slot locations:~%~D and ~F~%for slot ~A" - :format-arguments (list loc1 loc2 name))) - (progn - #+(or) - (format t "~%Assigning a default location ~D for ~A in ~A." - loc2 name (class-name class)) - (setf (slot-definition-location new-slotd) loc2)))) - (setf (slot-definition-initargs new-slotd) - (union (slot-definition-initargs new-slotd) - (slot-definition-initargs old-slotd))) - (unless (slot-definition-initfunction new-slotd) - (setf (slot-definition-initform new-slotd) - (slot-definition-initform old-slotd) - (slot-definition-initfunction new-slotd) - (slot-definition-initfunction old-slotd))) - (setf (slot-definition-readers new-slotd) - (union (slot-definition-readers new-slotd) - (slot-definition-readers old-slotd)) - (slot-definition-writers new-slotd) - (union (slot-definition-writers new-slotd) - (slot-definition-writers old-slotd)) - (slot-definition-type new-slotd) - ;; FIXME! we should be more smart then this: - (cond ((subtypep new-type old-type) new-type) - ((subtypep old-type new-type) old-type) - (T `(and ,new-type ,old-type)))) - new-slotd))) + (if (consp old-slot) + (copy-list old-slot) + (let ((initargs (slot-definition-to-plist old-slot))) + (apply #'make-instance + (apply #'effective-slot-definition-class class initargs) + initargs)))) + (combine-slotds (new-slotd old-slotd) + (let* ((new-type (slot-definition-type new-slotd)) + (old-type (slot-definition-type old-slotd)) + (loc1 (safe-slot-definition-location new-slotd)) + (loc2 (safe-slot-definition-location old-slotd))) + (when loc2 + (if loc1 + (unless (eql loc1 loc2) + (error 'simple-error + :format-control "You have specified two conflicting slot locations:~%~D and ~F~%for slot ~A" + :format-arguments (list loc1 loc2 name))) + (progn + #+(or) + (format t "~%Assigning a default location ~D for ~A in ~A." + loc2 name (class-name class)) + (setf (slot-definition-location new-slotd) loc2)))) + (setf (slot-definition-initargs new-slotd) + (union (slot-definition-initargs new-slotd) + (slot-definition-initargs old-slotd))) + (unless (slot-definition-initfunction new-slotd) + (setf (slot-definition-initform new-slotd) + (slot-definition-initform old-slotd) + (slot-definition-initfunction new-slotd) + (slot-definition-initfunction old-slotd))) + (setf (slot-definition-readers new-slotd) + (union (slot-definition-readers new-slotd) + (slot-definition-readers old-slotd)) + (slot-definition-writers new-slotd) + (union (slot-definition-writers new-slotd) + (slot-definition-writers old-slotd)) + (slot-definition-type new-slotd) + ;; FIXME! we should be more smart then this: + (cond ((subtypep new-type old-type) new-type) + ((subtypep old-type new-type) old-type) + (T `(and ,new-type ,old-type)))) + new-slotd))) (reduce #'combine-slotds (rest direct-slots) - :initial-value (direct-to-effective (first direct-slots))))) + :initial-value (direct-to-effective (first direct-slots))))) (defmethod compute-default-initargs ((class class)) (let ((all-initargs (mapappend #'class-direct-default-initargs - (class-precedence-list class)))) + (class-precedence-list class)))) ;; We have to use this trick because REMOVE-DUPLICATES on ;; ((:foo x) (:faa y) (:foo z)) would produce ((:faa y) (:foo z)) ;; and we want ((:foo x) (:faa y)) @@ -464,15 +464,15 @@ because it contains a reference to the undefined class~% ~A" ;;; shared by the metaclasses STANDARD-CLASS and STRUCTURE-CLASS. ;;; (defmethod ensure-class-using-class ((class class) name &rest rest - &key direct-slots direct-default-initargs) + &key direct-slots direct-default-initargs) (declare (ignore direct-default-initargs direct-slots)) (multiple-value-bind (metaclass direct-superclasses options) (apply #'help-ensure-class rest) (declare (ignore direct-superclasses)) (cond ((forward-referenced-class-p class) - (change-class class metaclass)) - ((not (eq (class-of class) metaclass)) - (error "When redefining a class, the metaclass can not change."))) + (change-class class metaclass)) + ((not (eq (class-of class) metaclass)) + (error "When redefining a class, the metaclass can not change."))) (setf class (apply #'reinitialize-instance class :name name options)) (when name (si:create-type-name name) @@ -481,27 +481,27 @@ because it contains a reference to the undefined class~% ~A" (defun coerce-to-class (class-or-symbol &optional (fail nil)) (cond ((si:instancep class-or-symbol) class-or-symbol) - ((not (symbolp class-or-symbol)) - (error "~a is not a valid class specifier." class-or-symbol)) - ((find-class class-or-symbol fail)) - (t - (warn 'si::simple-style-warning - :format-control "Class ~A has been forward referenced." - :format-arguments (list class-or-symbol)) - (ensure-class class-or-symbol - :metaclass 'forward-referenced-class - :direct-superclasses (list (find-class 'standard-object)) - :direct-slots '())))) + ((not (symbolp class-or-symbol)) + (error "~a is not a valid class specifier." class-or-symbol)) + ((find-class class-or-symbol fail)) + (t + (warn 'si::simple-style-warning + :format-control "Class ~A has been forward referenced." + :format-arguments (list class-or-symbol)) + (ensure-class class-or-symbol + :metaclass 'forward-referenced-class + :direct-superclasses (list (find-class 'standard-object)) + :direct-slots '())))) (defun help-ensure-class (&rest options - &key (metaclass 'standard-class) direct-superclasses - &allow-other-keys) + &key (metaclass 'standard-class) direct-superclasses + &allow-other-keys) (remf options :metaclass) (remf options :direct-superclasses) (setf metaclass (coerce-to-class metaclass t) - direct-superclasses (mapcar #'coerce-to-class direct-superclasses)) + direct-superclasses (mapcar #'coerce-to-class direct-superclasses)) (values metaclass direct-superclasses - (list* :direct-superclasses direct-superclasses options))) + (list* :direct-superclasses direct-superclasses options))) ;;; ---------------------------------------------------------------------- ;;; Around methods for COMPUTE-SLOTS which assign locations to each slot. @@ -514,24 +514,24 @@ because it contains a reference to the undefined class~% ~A" ;; assigned slot. Note the generalized comparison, which pushes all ;; slots without a defined location to the end of the list. (let* ((size (compute-instance-size slots)) - (instance-slots (remove :instance slots :key #'slot-definition-allocation - :test-not #'eq)) - (numbered-slots (remove-if-not #'safe-slot-definition-location instance-slots)) - (other-slots (remove-if #'safe-slot-definition-location instance-slots)) - (aux (make-array size :element-type 't :adjustable nil :initial-element nil))) + (instance-slots (remove :instance slots :key #'slot-definition-allocation + :test-not #'eq)) + (numbered-slots (remove-if-not #'safe-slot-definition-location instance-slots)) + (other-slots (remove-if #'safe-slot-definition-location instance-slots)) + (aux (make-array size :element-type 't :adjustable nil :initial-element nil))) (loop for i in numbered-slots do (let ((loc (slot-definition-location i))) - (when (aref aux loc) - (error 'simple-error - :format-control "Slots ~A and ~A are said to have the same location in class ~A." - :format-ars (list (aref aux loc) i class))) - (setf (aref aux loc) i))) + (when (aref aux loc) + (error 'simple-error + :format-control "Slots ~A and ~A are said to have the same location in class ~A." + :format-ars (list (aref aux loc) i class))) + (setf (aref aux loc) i))) (loop for i in other-slots with index = 0 do (loop while (aref aux index) - do (incf index) - finally (setf (aref aux index) i - (slot-definition-location i) index))) + do (incf index) + finally (setf (aref aux index) i + (slot-definition-location i) index))) slots)) (defmethod compute-slots :around ((class class)) @@ -542,23 +542,23 @@ because it contains a reference to the undefined class~% ~A" (let* ((direct-slots (class-direct-slots class))) (dolist (slotd slots) (let* ((name (slot-definition-name slotd)) - (allocation (slot-definition-allocation slotd))) - (cond ((not (eq (slot-definition-allocation slotd) :class))) - ((find name direct-slots :key #'slot-definition-name) ; new shared slot - (let* ((initfunc (slot-definition-initfunction slotd)) - (value (if initfunc (funcall initfunc) (unbound)))) - (setf (slot-definition-location slotd) (list value)))) - (t ; inherited shared slot - (dolist (c (class-precedence-list class)) - (unless (eql c class) - (let ((other (find (slot-definition-name slotd) - (class-slots c) - :key #'slot-definition-name))) - (when (and other - (eq (slot-definition-allocation other) allocation) - (setf (slot-definition-location slotd) - (slot-definition-location other))) - (return))))))))) + (allocation (slot-definition-allocation slotd))) + (cond ((not (eq (slot-definition-allocation slotd) :class))) + ((find name direct-slots :key #'slot-definition-name) ; new shared slot + (let* ((initfunc (slot-definition-initfunction slotd)) + (value (if initfunc (funcall initfunc) (unbound)))) + (setf (slot-definition-location slotd) (list value)))) + (t ; inherited shared slot + (dolist (c (class-precedence-list class)) + (unless (eql c class) + (let ((other (find (slot-definition-name slotd) + (class-slots c) + :key #'slot-definition-name))) + (when (and other + (eq (slot-definition-allocation other) allocation) + (setf (slot-definition-location slotd) + (slot-definition-location other))) + (return))))))))) slots)) (defmethod compute-slots :around ((class std-class)) @@ -572,33 +572,33 @@ because it contains a reference to the undefined class~% ~A" (defmethod describe-object ((obj standard-object) (stream t)) (let* ((class (si:instance-class obj)) - (slotds (class-slots class)) - slotname has-shared-slots) + (slotds (class-slots class)) + slotname has-shared-slots) (format stream "~%~S is an instance of class ~A" - obj (class-name class)) + obj (class-name class)) (when slotds ;; print instance slots (format stream "~%it has the following instance slots") (dolist (slot slotds) - (setq slotname (slot-definition-name slot)) - (case (slot-definition-allocation slot) - (:INSTANCE - (format stream "~%~A:~24,8T~A" - slotname - (if (slot-boundp obj slotname) - (slot-value obj slotname) "Unbound"))) - ;; :CLASS - (T (setq has-shared-slots t)))) + (setq slotname (slot-definition-name slot)) + (case (slot-definition-allocation slot) + (:INSTANCE + (format stream "~%~A:~24,8T~A" + slotname + (if (slot-boundp obj slotname) + (slot-value obj slotname) "Unbound"))) + ;; :CLASS + (T (setq has-shared-slots t)))) (when has-shared-slots - ;; print class slots - (format stream "~%it has the following class slots") - (dolist (slot slotds) - (setq slotname (slot-definition-name slot)) - (unless (eq (slot-definition-allocation slot) :INSTANCE) - (format stream "~%~A:~24,8T~A" - slotname - (if (slot-boundp obj slotname) - (slot-value obj slotname) "Unbound"))))))) + ;; print class slots + (format stream "~%it has the following class slots") + (dolist (slot slotds) + (setq slotname (slot-definition-name slot)) + (unless (eq (slot-definition-allocation slot) :INSTANCE) + (format stream "~%~A:~24,8T~A" + slotname + (if (slot-boundp obj slotname) + (slot-value obj slotname) "Unbound"))))))) obj) ;;; ---------------------------------------------------------------------- @@ -617,36 +617,36 @@ because it contains a reference to the undefined class~% ~A" nconc methods)) (defun check-initargs (class initargs &optional methods - (slots (class-slots class)) + (slots (class-slots class)) cached-keywords) ;; First get all initargs which have been declared in the given ;; methods, then check the list of initargs declared in the slots ;; of the class. (unless (or (eq methods t) (eq cached-keywords t)) (do* ((name-loc initargs (cddr name-loc)) - (allow-other-keys nil) - (allow-other-keys-found nil) - (unknown-key nil)) - ((null name-loc) - (when (and (not allow-other-keys) unknown-key) - (simple-program-error "Unknown initialization option ~S for class ~A" - unknown-key class))) + (allow-other-keys nil) + (allow-other-keys-found nil) + (unknown-key nil)) + ((null name-loc) + (when (and (not allow-other-keys) unknown-key) + (simple-program-error "Unknown initialization option ~S for class ~A" + unknown-key class))) (let ((name (first name-loc))) - (cond ((null (cdr name-loc)) - (simple-program-error "No value supplied for the init-name ~S." name)) - ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid - ;; slot-initarg. - ((and (eql name :ALLOW-OTHER-KEYS) - (not allow-other-keys-found)) - (setf allow-other-keys (second name-loc) - allow-other-keys-found t)) - ;; Check if the arguments is associated with a slot - ((member name slots :test #'member :key #'slot-definition-initargs)) - ;; The initialization argument has been declared in some method + (cond ((null (cdr name-loc)) + (simple-program-error "No value supplied for the init-name ~S." name)) + ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid + ;; slot-initarg. + ((and (eql name :ALLOW-OTHER-KEYS) + (not allow-other-keys-found)) + (setf allow-other-keys (second name-loc) + allow-other-keys-found t)) + ;; Check if the arguments is associated with a slot + ((member name slots :test #'member :key #'slot-definition-initargs)) + ;; The initialization argument has been declared in some method ((member name cached-keywords)) - ((and methods (member name methods :test #'member :key #'method-keywords))) - (t - (setf unknown-key name))))))) + ((and methods (member name methods :test #'member :key #'method-keywords))) + (t + (setf unknown-key name))))))) ;;; ---------------------------------------------------------------------- ;;; Methods @@ -654,21 +654,21 @@ because it contains a reference to the undefined class~% ~A" (defmethod describe-object ((obj std-class) (stream t)) (let ((slotds (class-slots (si:instance-class obj)))) (format stream "~%~A is an instance of class ~A" - obj (class-name (si:instance-class obj))) + obj (class-name (si:instance-class obj))) (do ((scan slotds (cdr scan)) - (i 0 (1+ i))) - ((null scan)) + (i 0 (1+ i))) + ((null scan)) (declare (fixnum i)) (print (slot-definition-name (car scan)) stream) - (princ ": " stream) + (princ ": " stream) (case (slot-definition-name (car scan)) - ((SUPERIORS INFERIORS PRECEDENCE-LIST) - (princ "(" stream) - (do* ((scan (si:instance-ref obj i) (cdr scan)) - (e (car scan) (car scan))) - ((null scan)) - (prin1 (class-name e) stream) - (when (cdr scan) (princ " " stream))) - (princ ")")) - (otherwise (prin1 (si:instance-ref obj i) stream))))) + ((SUPERIORS INFERIORS PRECEDENCE-LIST) + (princ "(" stream) + (do* ((scan (si:instance-ref obj i) (cdr scan)) + (e (car scan) (car scan))) + ((null scan)) + (prin1 (class-name e) stream) + (when (cdr scan) (princ " " stream))) + (princ ")")) + (otherwise (prin1 (si:instance-ref obj i) stream))))) obj) diff --git a/src/clos/std-accessors.lsp b/src/clos/std-accessors.lsp index 53b5e68bf..2a81926b6 100644 --- a/src/clos/std-accessors.lsp +++ b/src/clos/std-accessors.lsp @@ -22,46 +22,46 @@ (defun safe-slot-definition-location (slotd &optional default) (cond ((listp slotd) - (error "List instead of a slot definition object")) - (t - (slot-value slotd 'location)))) + (error "List instead of a slot definition object")) + (t + (slot-value slotd 'location)))) (defun std-class-sealed-accessors (index) (declare (si::c-local) - (fixnum index)) + (fixnum index)) (values #'(lambda (self) (declare (optimize (safety 0) (speed 3) (debug 0)) (standard-object self)) (ensure-up-to-date-instance self) - (safe-instance-ref self index)) - #'(lambda (value self) + (safe-instance-ref self index)) + #'(lambda (value self) (declare (optimize (safety 0) (speed 3) (debug 0)) (standard-object self)) (ensure-up-to-date-instance self) - (si:instance-set self index value)))) + (si:instance-set self index value)))) (defun std-class-accessors (slot-name) (declare (si::c-local)) ;; The following are very slow. We do not optimize for the slot position. (values #'(lambda (self) - (slot-value self slot-name)) - #'(lambda (value self) - (setf (slot-value self slot-name) value)))) + (slot-value self slot-name)) + #'(lambda (value self) + (setf (slot-value self slot-name) value)))) (defun safe-add-method (name method) ;; Adds a method to a function which might have been previously defined ;; as non-generic, without breaking the function (cond ((or *clos-booted* - (not (fboundp name)) - (si::instancep (fdefinition name))) - (add-method (ensure-generic-function name) method)) - (t - (let* ((alt-name '#:foo) - (gf (ensure-generic-function alt-name))) - (add-method gf method) - (setf (generic-function-name gf) name) - (setf (fdefinition name) gf) - (fmakunbound alt-name))))) + (not (fboundp name)) + (si::instancep (fdefinition name))) + (add-method (ensure-generic-function name) method)) + (t + (let* ((alt-name '#:foo) + (gf (ensure-generic-function alt-name))) + (add-method gf method) + (setf (generic-function-name gf) name) + (setf (fdefinition name) gf) + (fmakunbound alt-name))))) (defun std-class-generate-accessors (standard-class &optional (optimizable t)) ;; @@ -73,67 +73,67 @@ ;; (dolist (slotd (slot-value standard-class 'direct-slots)) (with-slots ((name name) (allocation allocation) (location location) - (readers readers) (writers writers)) - slotd + (readers readers) (writers writers)) + slotd ;; When a class is of a specified class in the MOP (such as ;; STANDARD-CLASS), then the user may not write any method ;; around SLOT-VALUE-USING-CLASS. This allows us to write ;; optimized versions of the accessors. (unless (member (slot-value standard-class 'name) - '(standard-class - funcallable-standard-class - structure-class)) - (setf optimizable nil)) + '(standard-class + funcallable-standard-class + structure-class)) + (setf optimizable nil)) (multiple-value-bind (reader writer) - (cond ((and optimizable - (eq allocation :instance) - ;; This is an extension by ECL in which a direct slot - ;; definition specifies the location of a slot. It - ;; only happens for sealed classes. - (typep location 'fixnum)) - (std-class-sealed-accessors location)) - (t - (std-class-accessors name))) - (let* ((options (list :slot-definition slotd)) - (reader-args (list* :function reader - :generic-function nil - :qualifiers nil - :lambda-list '(object) - :specializers `(,standard-class) - options)) - (reader-class (if (boundp '*early-methods*) - 'standard-reader-method - (apply #'reader-method-class standard-class slotd - reader-args))) - (writer-args (list* :function writer - :generic-function nil - :qualifiers nil - :lambda-list '(value object) - :specializers `(,(find-class t) ,standard-class) - options)) - (writer-class (if (boundp '*early-methods*) - 'standard-writer-method - (apply #'writer-method-class standard-class slotd - writer-args)))) - (dolist (fname readers) - (let ((method (make-method reader-class nil `(,standard-class) '(self) - (wrapped-method-function reader) - options))) - (safe-add-method fname method) - ;; This is redundant, but we need it at boot time because - ;; the early MAKE-METHOD does not use the options field. - (unless *clos-booted* - (setf (slot-value method 'slot-definition) slotd)))) - (dolist (fname writers) - (let ((method (make-method writer-class nil - `(,(find-class t) ,standard-class) '(value self) - (wrapped-method-function writer) - options))) - (safe-add-method fname method) - ;; This is redundant, but we need it at boot time because - ;; the early MAKE-METHOD does not use the options field. - (unless *clos-booted* - (setf (slot-value method 'slot-definition) slotd))))))))) + (cond ((and optimizable + (eq allocation :instance) + ;; This is an extension by ECL in which a direct slot + ;; definition specifies the location of a slot. It + ;; only happens for sealed classes. + (typep location 'fixnum)) + (std-class-sealed-accessors location)) + (t + (std-class-accessors name))) + (let* ((options (list :slot-definition slotd)) + (reader-args (list* :function reader + :generic-function nil + :qualifiers nil + :lambda-list '(object) + :specializers `(,standard-class) + options)) + (reader-class (if (boundp '*early-methods*) + 'standard-reader-method + (apply #'reader-method-class standard-class slotd + reader-args))) + (writer-args (list* :function writer + :generic-function nil + :qualifiers nil + :lambda-list '(value object) + :specializers `(,(find-class t) ,standard-class) + options)) + (writer-class (if (boundp '*early-methods*) + 'standard-writer-method + (apply #'writer-method-class standard-class slotd + writer-args)))) + (dolist (fname readers) + (let ((method (make-method reader-class nil `(,standard-class) '(self) + (wrapped-method-function reader) + options))) + (safe-add-method fname method) + ;; This is redundant, but we need it at boot time because + ;; the early MAKE-METHOD does not use the options field. + (unless *clos-booted* + (setf (slot-value method 'slot-definition) slotd)))) + (dolist (fname writers) + (let ((method (make-method writer-class nil + `(,(find-class t) ,standard-class) '(value self) + (wrapped-method-function writer) + options))) + (safe-add-method fname method) + ;; This is redundant, but we need it at boot time because + ;; the early MAKE-METHOD does not use the options field. + (unless *clos-booted* + (setf (slot-value method 'slot-definition) slotd))))))))) (defun reader-closure (index) (declare (si::c-local)) @@ -144,22 +144,22 @@ (lambda (value object) (si::instance-set object index value))) (labels ((generate-accessors (class) - (declare (optimize speed (safety 0))) - (if (and (typep class 'std-class) - #+(or) - (not (member (slot-value class 'name) - '(slot-definition - direct-slot-definition - effective-slot-definition - standard-slot-definition - standard-direct-slot-definition - standard-effective-slot-definition)))) - (std-class-generate-accessors class t) - (loop for slotd in (slot-value class 'slots) - for index = (slot-value slotd 'location) - do (loop for reader in (slot-value slotd 'readers) - do (setf (fdefinition reader) (reader-closure index))) - do (loop for writer in (slot-value slotd 'writers) - do (setf (fdefinition writer) (writer-closure index))))) - (mapc #'generate-accessors (slot-value class 'direct-subclasses)))) + (declare (optimize speed (safety 0))) + (if (and (typep class 'std-class) + #+(or) + (not (member (slot-value class 'name) + '(slot-definition + direct-slot-definition + effective-slot-definition + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition)))) + (std-class-generate-accessors class t) + (loop for slotd in (slot-value class 'slots) + for index = (slot-value slotd 'location) + do (loop for reader in (slot-value slotd 'readers) + do (setf (fdefinition reader) (reader-closure index))) + do (loop for writer in (slot-value slotd 'writers) + do (setf (fdefinition writer) (writer-closure index))))) + (mapc #'generate-accessors (slot-value class 'direct-subclasses)))) (generate-accessors +the-t-class+)) diff --git a/src/clos/std-slot-value.lsp b/src/clos/std-slot-value.lsp index e6168995a..0f3685ce9 100644 --- a/src/clos/std-slot-value.lsp +++ b/src/clos/std-slot-value.lsp @@ -40,14 +40,14 @@ ;;; (defmacro with-slots (slot-entries instance-form &body body) (let* ((temp (gensym)) - (accessors - (do ((scan slot-entries (cdr scan)) - (res)) - ((null scan) (nreverse res)) - (if (symbolp (first scan)) - (push `(,(first scan) (slot-value ,temp ',(first scan))) res) - (push `(,(caar scan) - (slot-value ,temp ',(cadar scan))) res))))) + (accessors + (do ((scan slot-entries (cdr scan)) + (res)) + ((null scan) (nreverse res)) + (if (symbolp (first scan)) + (push `(,(first scan) (slot-value ,temp ',(first scan))) res) + (push `(,(caar scan) + (slot-value ,temp ',(cadar scan))) res))))) `(let ((,temp ,instance-form)) (symbol-macrolet ,accessors ,@body)))) @@ -60,14 +60,14 @@ (eval-when (:compile-toplevel :execute) (defmacro with-early-accessors ((&rest slot-definitions) &rest body) `(macrolet - ,(loop for slots in slot-definitions - nconc (loop for (name . slotd) in (if (symbolp slots) - (symbol-value slots) - slots) - for index from 0 - for accessor = (getf slotd :accessor) - when accessor - collect `(,accessor (object) `(si::instance-ref ,object ,,index)))) + ,(loop for slots in slot-definitions + nconc (loop for (name . slotd) in (if (symbolp slots) + (symbol-value slots) + slots) + for index from 0 + for accessor = (getf slotd :accessor) + when accessor + collect `(,accessor (object) `(si::instance-ref ,object ,,index)))) ,@body))) ;;; @@ -76,30 +76,30 @@ ;;; (eval-when (:compile-toplevel :execute) (defmacro with-early-make-instance (slots (object class &rest key-value-pairs) - &rest body) + &rest body) (when (symbolp slots) (setf slots (symbol-value slots))) `(let* ((%class ,class) - (,object (si::allocate-raw-instance nil %class - ,(length slots)))) + (,object (si::allocate-raw-instance nil %class + ,(length slots)))) (declare (type standard-object ,object)) ,@(flet ((initializerp (name list) - (not (eq (getf list name 'wrong) 'wrong)))) - (loop for (name . slotd) in slots - for initarg = (getf slotd :initarg) - for initform = (getf slotd :initform (si::unbound)) - for initvalue = (getf key-value-pairs initarg) - for index from 0 - do (cond ((and initarg (initializerp initarg key-value-pairs)) - (setf initform (getf key-value-pairs initarg))) - ((initializerp name key-value-pairs) - (setf initform (getf key-value-pairs name)))) - when (si:sl-boundp initform) - collect `(si::instance-set ,object ,index ,initform))) + (not (eq (getf list name 'wrong) 'wrong)))) + (loop for (name . slotd) in slots + for initarg = (getf slotd :initarg) + for initform = (getf slotd :initform (si::unbound)) + for initvalue = (getf key-value-pairs initarg) + for index from 0 + do (cond ((and initarg (initializerp initarg key-value-pairs)) + (setf initform (getf key-value-pairs initarg))) + ((initializerp name key-value-pairs) + (setf initform (getf key-value-pairs name)))) + when (si:sl-boundp initform) + collect `(si::instance-set ,object ,index ,initform))) (when %class - (si::instance-sig-set ,object)) + (si::instance-sig-set ,object)) (with-early-accessors (,slots) - ,@body)))) + ,@body)))) ;;; ;;; ECL classes store slots in a hash table for faster access. The @@ -108,32 +108,32 @@ ;;; (defun std-create-slots-table (class) (with-slots ((all-slots slots) - (slot-table slot-table) - (location-table location-table)) + (slot-table slot-table) + (location-table location-table)) class (let* ((size (max 32 (* 2 (length all-slots)))) - (table (make-hash-table :size size))) + (table (make-hash-table :size size))) (dolist (slotd all-slots) - (setf (gethash (slot-definition-name slotd) table) slotd)) + (setf (gethash (slot-definition-name slotd) table) slotd)) (let ((metaclass (si::instance-class class)) - (locations nil)) - (when (or (eq metaclass (find-class 'standard-class)) - (eq metaclass (find-class 'funcallable-standard-class)) - (eq metaclass (find-class 'structure-class))) - (setf locations (make-hash-table :size size)) - (dolist (slotd all-slots) - (setf (gethash (slot-definition-name slotd) locations) - (slot-definition-location slotd)))) - (setf slot-table table - location-table locations))))) + (locations nil)) + (when (or (eq metaclass (find-class 'standard-class)) + (eq metaclass (find-class 'funcallable-standard-class)) + (eq metaclass (find-class 'structure-class))) + (setf locations (make-hash-table :size size)) + (dolist (slotd all-slots) + (setf (gethash (slot-definition-name slotd) locations) + (slot-definition-location slotd)))) + (setf slot-table table + location-table locations))))) (defun find-slot-definition (class slot-name) (with-slots ((slots slots) (slot-table slot-table)) class (if (or (eq (si:instance-class class) +the-standard-class+) - (eq (si:instance-class class) +the-funcallable-standard-class+)) - (gethash slot-name slot-table nil) - (find slot-name slots :key #'slot-definition-name)))) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (gethash slot-name slot-table nil) + (find slot-name slots :key #'slot-definition-name)))) ;;; ;;; INSTANCE UPDATE PREVIOUS @@ -146,12 +146,12 @@ ;; class is updated, the list is newly created. Structures are also ;; "instances" but keep ECL_UNBOUND instead of the list. `(let* ((i ,instance) - (s (si::instance-sig i))) + (s (si::instance-sig i))) (declare (:read-only i s)) (with-early-accessors (+standard-class-slots+) - (when (si:sl-boundp s) - (unless (eq s (class-slots (si::instance-class i))) - (update-instance i))))))) + (when (si:sl-boundp s) + (unless (eq s (class-slots (si::instance-class i))) + (update-instance i))))))) (defun update-instance (x) (si::instance-sig-set x)) @@ -165,29 +165,29 @@ (defun standard-instance-access (instance location) (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (ensure-up-to-date-instance instance) (cond ((ext:fixnump location) - ;; local slot - (si:instance-ref instance (truly-the fixnum location))) - ((consp location) - ;; shared slot - (car location)) - (t - (invalid-slot-location instance location))))) + ;; local slot + (si:instance-ref instance (truly-the fixnum location))) + ((consp location) + ;; shared slot + (car location)) + (t + (invalid-slot-location instance location))))) (defun standard-instance-set (instance location val) (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (ensure-up-to-date-instance instance) (cond ((ext:fixnump location) - ;; local slot - (si:instance-set instance (truly-the fixnum location) val)) - ((consp location) - ;; shared slot - (setf (car location) val)) - (t - (invalid-slot-location instance location))) + ;; local slot + (si:instance-set instance (truly-the fixnum location) val)) + ((consp location) + ;; shared slot + (setf (car location) val)) + (t + (invalid-slot-location instance location))) val)) (defsetf standard-instance-access standard-instance-set) @@ -195,21 +195,21 @@ (defun slot-value (self slot-name) (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (let* ((class (class-of self)) - (location-table (class-location-table class))) + (location-table (class-location-table class))) (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (let ((value (standard-instance-access self location))) - (if (si:sl-boundp value) - value - (values (slot-unbound class self slot-name)))) - (slot-missing class self slot-name 'SLOT-VALUE))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (slot-value-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-VALUE)))))))) + (let ((location (gethash slot-name location-table nil))) + (if location + (let ((value (standard-instance-access self location))) + (if (si:sl-boundp value) + value + (values (slot-unbound class self slot-name)))) + (slot-missing class self slot-name 'SLOT-VALUE))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-value-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-VALUE)))))))) (defun slot-exists-p (self slot-name) (and (find-slot-definition (class-of self) slot-name) @@ -217,33 +217,33 @@ (defun slot-boundp (self slot-name) (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (let* ((class (class-of self)) - (location-table (class-location-table class))) + (location-table (class-location-table class))) (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (si:sl-boundp (standard-instance-access self location)) - (values (slot-missing class self slot-name 'SLOT-BOUNDP)))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (slot-boundp-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-BOUNDP)))))))) + (let ((location (gethash slot-name location-table nil))) + (if location + (si:sl-boundp (standard-instance-access self location)) + (values (slot-missing class self slot-name 'SLOT-BOUNDP)))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-BOUNDP)))))))) (defun clos::slot-value-set (value self slot-name) (with-early-accessors (+standard-class-slots+ - +slot-definition-slots+) + +slot-definition-slots+) (let* ((class (class-of self)) - (location-table (class-location-table class))) + (location-table (class-location-table class))) (if location-table - (let ((location (gethash slot-name location-table nil))) - (if location - (setf (standard-instance-access self location) value) - (slot-missing class self slot-name 'SETF value))) - (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) - (if slotd - (setf (slot-value-using-class class self slotd) value) - (slot-missing class self slot-name 'SETF value)))))) + (let ((location (gethash slot-name location-table nil))) + (if location + (setf (standard-instance-access self location) value) + (slot-missing class self slot-name 'SETF value))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (setf (slot-value-using-class class self slotd) value) + (slot-missing class self slot-name 'SETF value)))))) value) (setf (fdefinition '(setf slot-value)) #'clos::slot-value-set) @@ -254,6 +254,6 @@ (defun invalid-slot-location (instance location) (declare (si::c-local) - (ignore instance)) + (ignore instance)) (error "Invalid location ~A when accessing slot of class ~A" - location (class-of location))) + location (class-of location))) diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index 5512e0ff2..0d4dfe6aa 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -22,15 +22,15 @@ (declare (ignore reqs opts rest-var)) (when key-flag (do* ((output '()) - (l (cdr keywords) (cddddr l))) - ((endp l) - output) - (push (first l) output))))) + (l (cdr keywords) (cddddr l))) + ((endp l) + output) + (push (first l) output))))) (defmethod shared-initialize ((method standard-method) slot-names &rest initargs - &key (specializers nil spec-supplied-p) - (lambda-list nil lambda-supplied-p) - generic-function) + &key (specializers nil spec-supplied-p) + (lambda-list nil lambda-supplied-p) + generic-function) (declare (ignore initargs method slot-names)) (when slot-names (unless spec-supplied-p @@ -38,15 +38,15 @@ (unless lambda-supplied-p (error "Lambda list not supplied in method initialization")) (unless (= (first (si::process-lambda-list lambda-list 'method)) - (length specializers)) + (length specializers)) (error "The list of specializers does not match the number of required arguments in the lambda list ~A" - lambda-list))) + lambda-list))) (when spec-supplied-p (loop for s in specializers unless (typep s 'specializer) do (error "Object ~A is not a valid specializer" s))) (setf method (call-next-method) - (method-keywords method) (compute-method-keywords (method-lambda-list method))) + (method-keywords method) (compute-method-keywords (method-lambda-list method))) method) #+threads @@ -58,8 +58,8 @@ (let ((table *eql-specializer-hash*)) (mp:with-lock (*eql-specializer-lock*) (or (gethash object table nil) - (setf (gethash object table) - (make-instance 'eql-specializer :object object)))))) + (setf (gethash object table) + (make-instance 'eql-specializer :object object)))))) (defmethod add-direct-method ((spec specializer) (method method)) (pushnew method (specializer-direct-methods spec)) @@ -69,11 +69,11 @@ (defmethod remove-direct-method ((spec specializer) (method method)) (let* ((gf (method-generic-function method)) - (methods (delete method (specializer-direct-methods spec)))) + (methods (delete method (specializer-direct-methods spec)))) (setf (specializer-direct-methods spec) methods) (unless (find gf methods :key #'method-generic-function) (setf (specializer-direct-generic-functions spec) - (delete gf (specializer-direct-generic-functions spec)))) + (delete gf (specializer-direct-generic-functions spec)))) (values))) (defmethod remove-direct-method ((spec eql-specializer) (method method)) diff --git a/src/clos/streams.lsp b/src/clos/streams.lsp index 8c3252c93..afdeb5a94 100644 --- a/src/clos/streams.lsp +++ b/src/clos/streams.lsp @@ -272,12 +272,12 @@ ;; STREAM-ADVANCE-TO-COLUMN (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) - column) + column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (- column current-column))) - (dotimes (i fill) - (stream-write-char stream #\Space))) + (dotimes (i fill) + (stream-write-char stream #\Space))) T))) @@ -504,22 +504,22 @@ (defmethod stream-read-line ((stream fundamental-character-input-stream)) (let ((res (make-string 80)) - (len 80) - (index 0)) + (len 80) + (index 0)) (loop (let ((ch (stream-read-char stream))) (cond ((eq ch :eof) - (return (values (si::shrink-vector res index) t))) - (t - (when (char= ch #\newline) - (return (values (si::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))))))) + (return (values (si::shrink-vector res index) t))) + (t + (when (char= ch #\newline) + (return (values (si::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))))))) (defmethod stream-read-line ((stream ansi-stream)) (cl:read-line stream)) @@ -539,7 +539,7 @@ (si::do-read-sequence sequence stream start end)) (defmethod stream-read-sequence ((stream ansi-stream) sequence - &optional (start 0) (end nil)) + &optional (start 0) (end nil)) (si:do-read-sequence stream sequence start end)) (defmethod stream-read-sequence ((stream t) sequence &optional start end) @@ -613,15 +613,15 @@ ;; WRITE-STRING (defmethod stream-write-string ((stream fundamental-character-output-stream) - string &optional (start 0) end) + string &optional (start 0) end) (declare (type t stream) ; check for c::stream-designator ignored (string string) - (fixnum start) + (fixnum start) (ext:check-arguments-type)) (let ((end (or end (length string)))) (declare (fixnum end)) (do ((pos start (1+ pos))) - ((>= pos end)) + ((>= pos end)) (declare (type si::index pos)) (stream-write-char stream (aref string pos)))) string) @@ -690,7 +690,7 @@ (eval-when (:compile-toplevel :execute) (defconstant +conflicting-symbols+ '(cl:close cl:stream-element-type cl:input-stream-p - cl:open-stream-p cl:output-stream-p cl:streamp))) + cl:open-stream-p cl:output-stream-p cl:streamp))) (let ((p (find-package "GRAY"))) (export '(nil) p) diff --git a/src/clos/walk.lsp b/src/clos/walk.lsp index e97626e31..2fea7bb3e 100644 --- a/src/clos/walk.lsp +++ b/src/clos/walk.lsp @@ -62,20 +62,20 @@ ;;; (defpackage "WALKER" (:export define-walker-template - walk-form - walk-form-expand-macros-p - #-ecl nested-walk-form - variable-lexical-p - variable-special-p - *variable-declarations* - variable-declaration - macroexpand-all - ) + walk-form + walk-form-expand-macros-p + #-ecl nested-walk-form + variable-lexical-p + variable-special-p + *variable-declarations* + variable-declaration + macroexpand-all + ) (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP")) (in-package "WALKER") (declaim (notinline note-lexical-binding walk-bindings-1 walk-let/let* - walk-form-internal)) + walk-form-internal)) (push :new *features*) @@ -137,15 +137,15 @@ ;;; (defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) + ((new-env old-env &key functions macros) &body body) + `(let ((,new-env (with-augmented-environment-internal ,old-env + ,functions + ,macros))) + ,@body)) (defun with-augmented-environment-internal (env functions macros) (let* ((vars (car env)) - (funs (cdr env))) + (funs (cdr env))) (dolist (f functions) (push `(,(car f) function ,#'unbound-lexical-function) funs)) (dolist (m macros) @@ -155,41 +155,41 @@ #+nil (defun environment-function (env fn) (when env - (let ((entry (assoc fn (cdr env)))) - (and entry - (eq (second entry) 'FUNCTION) - (third entry))))) + (let ((entry (assoc fn (cdr env)))) + (and entry + (eq (second entry) 'FUNCTION) + (third entry))))) (defun environment-macro (env macro) (declare (si::c-local)) (when env - (let ((entry (assoc macro (cdr env)))) - (and entry - (eq (second entry) 'MACRO) - (third entry))))) + (let ((entry (assoc macro (cdr env)))) + (and entry + (eq (second entry) 'MACRO) + (third entry))))) (defmacro with-new-definition-in-environment - ((new-env old-env macrolet/flet/labels-form) &body body) + ((new-env old-env macrolet/flet/labels-form) &body body) (let* ((functions (make-symbol "Functions")) - (macros (make-symbol "Macros"))) + (macros (make-symbol "Macros"))) `(let ((,functions ()) - (,macros ())) + (,macros ())) (ecase (car ,macrolet/flet/labels-form) - ((FLET LABELS) - (dolist (fn (second ,macrolet/flet/labels-form)) - (push fn ,functions))) - ((MACROLET) - (dolist (mac (second ,macrolet/flet/labels-form)) - (push (list (car mac) - (convert-macro-to-lambda (second mac) - (cddr mac) - (string (car mac)))) - ,macros)))) + ((FLET LABELS) + (dolist (fn (second ,macrolet/flet/labels-form)) + (push fn ,functions))) + ((MACROLET) + (dolist (mac (second ,macrolet/flet/labels-form)) + (push (list (car mac) + (convert-macro-to-lambda (second mac) + (cddr mac) + (string (car mac)))) + ,macros)))) (with-augmented-environment - (,new-env ,old-env :functions ,functions :macros ,macros) - ,@body)))) + (,new-env ,old-env :functions ,functions :macros ,macros) + ,@body)))) (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) (declare (si::c-local)) @@ -208,7 +208,7 @@ ;;; nested-walk-form facility work properly. ;;; (defmacro walker-environment-bind ((var env &rest key-args) - &body body) + &body body) `(with-augmented-environment (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) .,body)) @@ -220,17 +220,17 @@ (environment-macro env *key-to-walker-environment*)) (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) - (walk-form nil wfop) - (declarations nil decp) - (lexical-variables nil lexp)) + (walk-form nil wfop) + (declarations nil decp) + (lexical-variables nil lexp)) (declare (si::c-local)) (let ((lock (env-lock env))) (list (list *key-to-walker-environment* - (list (if wfnp walk-function (car lock)) - (if wfop walk-form (second lock)) - (if decp declarations (third lock)) - (if lexp lexical-variables (fourth lock))))))) + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (second lock)) + (if decp declarations (third lock)) + (if lexp lexical-variables (fourth lock))))))) (defun env-walk-function (env) (declare (si::c-local)) @@ -274,12 +274,12 @@ (if (not (member declaration *variable-declarations*)) (error "~S is not a recognized variable declaration." declaration) (let ((id (or (variable-lexical-p var env) var))) - (dolist (decl (env-declarations env)) - (when (and (eq (car decl) declaration) - (or (eq (second decl) id) - (and (eq 'TYPE (car decl)) - (member var (cddr decl) :test #'eq)))) ; Beppe - (return decl)))))) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (or (eq (second decl) id) + (and (eq 'TYPE (car decl)) + (member var (cddr decl) :test #'eq)))) ; Beppe + (return decl)))))) (defun VARIABLE-SPECIAL-P (var env) (or (not (null (variable-declaration 'SPECIAL var env))) @@ -358,24 +358,24 @@ (eval-when (#-cross compile load eval) (defmacro get-walker-template-internal (x) ;Has to be inside eval-when because - `(get-sysprop ,x 'WALKER-TEMPLATE)) ;Golden Common Lisp doesn't hack - ;compile time definition of macros - ;right for setf. + `(get-sysprop ,x 'WALKER-TEMPLATE)) ;Golden Common Lisp doesn't hack + ;compile time definition of macros + ;right for setf. (defmacro define-walker-template - (name &optional (template '(NIL REPEAT (EVAL)))) + (name &optional (template '(NIL REPEAT (EVAL)))) `(eval-when (load eval) (put-sysprop ',name 'WALKER-TEMPLATE ',template))) ) (defun get-walker-template (x) (cond ((symbolp x) - (or (get-walker-template-internal x) - (get-implementation-dependent-walker-template x))) - ((and (listp x) (eq (car x) 'LAMBDA)) - '(LAMBDA REPEAT (EVAL))) - (t - (error "Can't get template for ~S" x)))) + (or (get-walker-template-internal x) + (get-implementation-dependent-walker-template x))) + ((and (listp x) (eq (car x) 'LAMBDA)) + '(LAMBDA REPEAT (EVAL))) + (t + (error "Can't get template for ~S" x)))) (defun get-implementation-dependent-walker-template (x) (declare (ignore x)) @@ -423,21 +423,21 @@ ;;; And the extra templates... ;;; #+ecl -(define-walker-template DOTIMES walk-dotimes/dolist) +(define-walker-template DOTIMES walk-dotimes/dolist) #+ecl -(define-walker-template DOLIST walk-dotimes/dolist) +(define-walker-template DOLIST walk-dotimes/dolist) #+ecl -(define-walker-template WHEN walk-when/unless) +(define-walker-template WHEN walk-when/unless) #+ecl -(define-walker-template UNLESS walk-when/unless) +(define-walker-template UNLESS walk-when/unless) (define-walker-template DO walk-do) (define-walker-template DO* walk-do*) (define-walker-template PROG walk-prog) (define-walker-template PROG* walk-prog*) (define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) -(define-walker-template ext::lambda-block walk-named-lambda) ;Not really right, but - ;we don't hack block - ;names anyways. +(define-walker-template ext::lambda-block walk-named-lambda) ;Not really right, but + ;we don't hack block + ;names anyways. #+ecl (define-walker-template ffi::c-inline walk-c-inline) @@ -450,11 +450,11 @@ (walk-form form environment))) (defun WALK-FORM (form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) + &optional environment + (walk-function + #'(lambda (subform context env) + (declare (ignore context env)) + subform))) (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) @@ -479,51 +479,51 @@ ;;; #-ecl (defun NESTED-WALK-FORM (whole - form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) + form + &optional environment + (walk-function + #'(lambda (subform context env) + (declare (ignore context env)) + subform))) (if (eq whole (env-walk-form environment)) (let ((outer-walk-function (env-walk-function environment))) - (throw whole - (walk-form - form - environment - #'(lambda (f c e) - ;; First loop to make sure the inner walk function - ;; has done all it wants to do with this form. - ;; Basically, what we are doing here is providing - ;; the same contract walk-form-internal normally - ;; provides to the inner walk function. - (let*((inner-result nil) - (inner-no-more-p nil) - (outer-result nil) - (outer-no-more-p nil)) - (loop - (multiple-value-setq (inner-result inner-no-more-p) - (funcall walk-function f c e)) - (cond (inner-no-more-p (return)) - ((not (eq inner-result f))) - ((not (consp inner-result)) (return)) - ((get-walker-template (car inner-result)) (return)) - (t - (multiple-value-bind (expansion macrop) - (walker-environment-bind - (new-env e :walk-form inner-result) - (macroexpand-1 inner-result new-env)) - (if macrop - (setq inner-result expansion) - (return))))) - (setq f inner-result)) - (multiple-value-setq (outer-result outer-no-more-p) - (funcall outer-walk-function - inner-result - c - e)) - (values outer-result - (and inner-no-more-p outer-no-more-p))))))) + (throw whole + (walk-form + form + environment + #'(lambda (f c e) + ;; First loop to make sure the inner walk function + ;; has done all it wants to do with this form. + ;; Basically, what we are doing here is providing + ;; the same contract walk-form-internal normally + ;; provides to the inner walk function. + (let*((inner-result nil) + (inner-no-more-p nil) + (outer-result nil) + (outer-no-more-p nil)) + (loop + (multiple-value-setq (inner-result inner-no-more-p) + (funcall walk-function f c e)) + (cond (inner-no-more-p (return)) + ((not (eq inner-result f))) + ((not (consp inner-result)) (return)) + ((get-walker-template (car inner-result)) (return)) + (t + (multiple-value-bind (expansion macrop) + (walker-environment-bind + (new-env e :walk-form inner-result) + (macroexpand-1 inner-result new-env)) + (if macrop + (setq inner-result expansion) + (return))))) + (setq f inner-result)) + (multiple-value-setq (outer-result outer-no-more-p) + (funcall outer-walk-function + inner-result + c + e)) + (values outer-result + (and inner-no-more-p outer-no-more-p))))))) (walk-form form environment walk-function))) ;;; @@ -543,7 +543,7 @@ ;;; (defun walk-form-internal (form context env - &aux fn template) + &aux fn template) ;; First apply the walk-function to perform whatever translation ;; the user wants to this form. If the second value returned ;; by walk-function is T then we don't recurse... @@ -551,47 +551,47 @@ (multiple-value-bind (newform walk-no-more-p) (funcall (env-walk-function env) form context env) (catch newform - (cond (walk-no-more-p newform) - ((not (eq form newform)) - (walk-form-internal newform context env)) - ((not (consp newform)) - (let ((symmac (car (variable-symbol-macro-p newform env)))) - (if symmac - (let ((newnewform (walk-form-internal (cddr symmac) - context env))) - (if (eq newnewform (cddr symmac)) - (if walk-form-expand-macros-p newnewform newform) - newnewform)) - newform))) - ((setq template (get-walker-template (setq fn (car newform)))) - (if (symbolp template) - (funcall template newform context env) - (walk-template newform template context env))) - (t - (multiple-value-bind (newnewform macrop) - (walker-environment-bind (new-env env :walk-form newform) - (macroexpand-1 newform new-env)) - (cond - (macrop - (let ((newnewnewform - (walk-form-internal newnewform context env))) - (if (eq newnewnewform newnewform) - (if walk-form-expand-macros-p newnewform newform) - newnewnewform))) - ((and (symbolp fn) - (not (fboundp fn)) - (special-operator-p fn)) - (error - "~S is a special form, not defined in the CommonLisp.~%~ + (cond (walk-no-more-p newform) + ((not (eq form newform)) + (walk-form-internal newform context env)) + ((not (consp newform)) + (let ((symmac (car (variable-symbol-macro-p newform env)))) + (if symmac + (let ((newnewform (walk-form-internal (cddr symmac) + context env))) + (if (eq newnewform (cddr symmac)) + (if walk-form-expand-macros-p newnewform newform) + newnewform)) + newform))) + ((setq template (get-walker-template (setq fn (car newform)))) + (if (symbolp template) + (funcall template newform context env) + (walk-template newform template context env))) + (t + (multiple-value-bind (newnewform macrop) + (walker-environment-bind (new-env env :walk-form newform) + (macroexpand-1 newform new-env)) + (cond + (macrop + (let ((newnewnewform + (walk-form-internal newnewform context env))) + (if (eq newnewnewform newnewform) + (if walk-form-expand-macros-p newnewform newform) + newnewnewform))) + ((and (symbolp fn) + (not (fboundp fn)) + (special-operator-p fn)) + (error + "~S is a special form, not defined in the CommonLisp.~%~ manual This code walker doesn't know how to walk it.~%~ Define a template for this special form and try again." - fn)) - (t - ;; Otherwise, walk the form as if its just a standard - ;; functioncall using a template for standard function - ;; call. - (walk-template - newnewform '(CALL REPEAT (EVAL)) context env)))))))))) + fn)) + (t + ;; Otherwise, walk the form as if its just a standard + ;; functioncall using a template for standard function + ;; call. + (walk-template + newnewform '(CALL REPEAT (EVAL)) context env)))))))))) (defun walk-template (form template context env) (declare (si::c-local)) @@ -603,58 +603,58 @@ (SET (walk-form-internal form :SET env)) ((LAMBDA CALL) - (cond ((or (symbolp form) - (and (listp form) - (= (length form) 2) - (eq (car form) 'SETF))) form) - (t (walk-form-internal form context env))))) + (cond ((or (symbolp form) + (and (listp form) + (= (length form) 2) + (eq (car form) 'SETF))) form) + (t (walk-form-internal form context env))))) (case (car template) (REPEAT (walk-template-handle-repeat form (cdr template) - ;; For the case where nothing happens - ;; after the repeat optimize out the - ;; call to length. - (if (null (cddr template)) - () - (nthcdr (- (length form) - (length - (cddr template))) - form)) + ;; For the case where nothing happens + ;; after the repeat optimize out the + ;; call to length. + (if (null (cddr template)) + () + (nthcdr (- (length form) + (length + (cddr template))) + form)) context - env)) + env)) (IF - (walk-template form - (if (if (listp (second template)) - (eval (second template)) - (funcall (second template) form)) - (third template) - (fourth template)) - context - env)) + (walk-template form + (if (if (listp (second template)) + (eval (second template)) + (funcall (second template) form)) + (third template) + (fourth template)) + context + env)) (REMOTE (walk-template form (second template) context env)) (otherwise (cond ((atom form) form) (t (recons form (walk-template - (car form) (car template) context env) + (car form) (car template) context env) (walk-template - (cdr form) (cdr template) context env)))))))) + (cdr form) (cdr template) context env)))))))) (defun walk-template-handle-repeat (form template stop-form context env) (declare (si::c-local)) (if (eq form stop-form) (walk-template form (cdr template) context env) (walk-template-handle-repeat-1 form - template - (car template) - stop-form - context - env))) + template + (car template) + stop-form + context + env))) (defun walk-template-handle-repeat-1 (form template repeat-template - stop-form context env) + stop-form context env) (declare (si::c-local)) (cond ((null form) ()) ((eq form stop-form) @@ -664,22 +664,22 @@ Ran into stop while still in repeat template."))) ((null repeat-template) (walk-template-handle-repeat-1 - form template (car template) stop-form context env)) + form template (car template) stop-form context env)) (t (recons form (walk-template (car form) (car repeat-template) context env) (walk-template-handle-repeat-1 (cdr form) - template - (cdr repeat-template) - stop-form - context - env))))) + template + (cdr repeat-template) + stop-form + context + env))))) (defun walk-repeat-eval (form env) (and form (recons form - (walk-form-internal (car form) :eval env) - (walk-repeat-eval (cdr form) env)))) + (walk-form-internal (car form) :eval env) + (walk-repeat-eval (cdr form) env)))) (defun recons (x car cdr) (if (or (not (eq (car x) car)) @@ -702,8 +702,8 @@ (if (null (cdr args)) (if *p (car args) (recons x (car args) nil)) (recons x - (car args) - (relist-internal (cdr x) (cdr args) *p)))) + (car args) + (relist-internal (cdr x) (cdr args) *p)))) ;; @@ -711,62 +711,62 @@ ;; (defun walk-declarations (body fn env - &optional doc-string-p declarations old-body - &aux (form (car body)) macrop new-form) + &optional doc-string-p declarations old-body + &aux (form (car body)) macrop new-form) (declare (si::c-local)) - (cond ((and (stringp form) ;might be a doc string - (cdr body) ;isn't the returned value - (null doc-string-p) ;no doc string yet - (null declarations)) ;no declarations yet + (cond ((and (stringp form) ;might be a doc string + (cdr body) ;isn't the returned value + (null doc-string-p) ;no doc string yet + (null declarations)) ;no declarations yet (recons body form (walk-declarations (cdr body) fn env t))) ((and (listp form) (eq (car form) 'DECLARE)) ;; Got ourselves a real live declaration. Record it, look for more. (dolist (declaration (cdr form)) - (let*((type (car declaration)) - (name (second declaration)) - (args (cddr declaration))) - (if (member type *variable-declarations*) - (note-declaration `(,type - ,(or (variable-lexical-p name env) name) - ,.args) - env) - (note-declaration declaration env)) - (push declaration declarations))) + (let*((type (car declaration)) + (name (second declaration)) + (args (cddr declaration))) + (if (member type *variable-declarations*) + (note-declaration `(,type + ,(or (variable-lexical-p name env) name) + ,.args) + env) + (note-declaration declaration env)) + (push declaration declarations))) (recons body form (walk-declarations - (cdr body) fn env doc-string-p declarations))) + (cdr body) fn env doc-string-p declarations))) ((and form - (listp form) - (null (get-walker-template (car form))) - (progn - (multiple-value-setq (new-form macrop) - (macroexpand-1 form env)) - macrop)) - ;; This form was a call to a macro. Maybe it expanded - ;; into a declare? Recurse to find out. - (walk-declarations (recons body new-form (cdr body)) - fn env doc-string-p declarations - (or old-body body))) - (t - ;; Now that we have walked and recorded the declarations, - ;; call the function our caller provided to expand the body. - ;; We call that function rather than passing the real-body - ;; back, because we are RECONSING up the new body. - (funcall fn (or old-body body) env)))) + (listp form) + (null (get-walker-template (car form))) + (progn + (multiple-value-setq (new-form macrop) + (macroexpand-1 form env)) + macrop)) + ;; This form was a call to a macro. Maybe it expanded + ;; into a declare? Recurse to find out. + (walk-declarations (recons body new-form (cdr body)) + fn env doc-string-p declarations + (or old-body body))) + (t + ;; Now that we have walked and recorded the declarations, + ;; call the function our caller provided to expand the body. + ;; We call that function rather than passing the real-body + ;; back, because we are RECONSING up the new body. + (funcall fn (or old-body body) env)))) (defun walk-unexpected-declare (form context env) (declare (ignore context env) - (si::c-local)) + (si::c-local)) (warn "Encountered declare ~S in a place where a declare was not expected." - form) + form) form) (defun walk-arglist (arglist context env &optional (destructuringp nil) - &aux arg) + &aux arg) (declare (si::c-local)) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) @@ -776,19 +776,19 @@ arg (walk-arglist (cdr arglist) context - env + env (and destructuringp - (not (member arg - lambda-list-keywords)))))) + (not (member arg + lambda-list-keywords)))))) ((consp arg) (prog1 (recons arglist - (if destructuringp - (walk-arglist arg context env destructuringp) - (relist* arg - (car arg) - (walk-form-internal (second arg) :eval env) - (cddr arg))) - (walk-arglist (cdr arglist) context env nil)) + (if destructuringp + (walk-arglist arg context env destructuringp) + (relist* arg + (car arg) + (walk-form-internal (second arg) :eval env) + (cddr arg))) + (walk-arglist (cdr arglist) context env nil)) (if (symbolp (car arg)) (note-lexical-binding (car arg) env) (note-lexical-binding (cadar arg) env)) @@ -796,7 +796,7 @@ (not (symbolp (third arg))) (note-lexical-binding (third arg) env)))) (t - (error "Can't understand something in the arglist ~S" arglist)))) + (error "Can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) @@ -819,129 +819,129 @@ (defun walk-let/let* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((let/let* (car form)) - (bindings (second form)) - (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (bindings (second form)) + (body (cddr form)) + (walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* - form let/let* walked-bindings walked-body)))) + form let/let* walked-bindings walked-body)))) (defun walk-locally (form context env) (declare (ignore context)) (let* ((locally (car form)) - (body (cdr form)) - (walked-body - (walk-declarations body #'walk-repeat-eval env))) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval env))) (relist* form locally walked-body))) (defun walk-prog/prog* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((possible-block-name (second form)) - (blocked-prog (and (symbolp possible-block-name) - (not (eq possible-block-name 'nil))))) + (blocked-prog (and (symbolp possible-block-name) + (not (eq possible-block-name 'nil))))) (multiple-value-bind (let/let* block-name bindings body) - (if blocked-prog - (values (car form) (cadr form) (caddr form) (cdddr form)) - (values (car form) nil (cadr form) (cddr form))) - (let* ((walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (walk-tagbody-1 real-body context real-env)) - new-env))) - (if block-name - (relist* - form let/let* block-name walked-bindings walked-body) - (relist* - form let/let* walked-bindings walked-body))))))) + (if blocked-prog + (values (car form) (cadr form) (caddr form) (cdddr form)) + (values (car form) nil (cadr form) (cddr form))) + (let* ((walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations + body + #'(lambda (real-body real-env) + (walk-tagbody-1 real-body context real-env)) + new-env))) + (if block-name + (relist* + form let/let* block-name walked-bindings walked-body) + (relist* + form let/let* walked-bindings walked-body))))))) (defun walk-do/do* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((do/do* (car form)) - (bindings (second form)) - (end-test (third form)) - (body (cdddr form)) - (walked-bindings (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (bindings (second form)) + (end-test (third form)) + (body (cdddr form)) + (walked-bindings (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - do/do* - (walk-bindings-2 bindings walked-bindings context new-env) - (walk-template end-test '(TEST REPEAT (EVAL)) context new-env) - walked-body)))) + do/do* + (walk-bindings-2 bindings walked-bindings context new-env) + (walk-template end-test '(TEST REPEAT (EVAL)) context new-env) + walked-body)))) #+ecl (defun walk-dotimes/dolist (form context old-env) (walker-environment-bind (new-env old-env) (let* ((dotimes/dolist (car form)) - (bindings (second form)) - (body (cddr form)) - ; This is a hack. We tread BINDINGS as we - ; would in a DO/DO* loop. - (walked-bindings (walk-bindings-1 bindings - old-env - new-env - context - t)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (bindings (second form)) + (body (cddr form)) + ; This is a hack. We tread BINDINGS as we + ; would in a DO/DO* loop. + (walked-bindings (walk-bindings-1 bindings + old-env + new-env + context + t)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - dotimes/dolist - (walk-bindings-2 bindings walked-bindings context new-env) - walked-body)))) + dotimes/dolist + (walk-bindings-2 bindings walked-bindings context new-env) + walked-body)))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) (if (some #'(lambda (var) - (variable-symbol-macro-p var env)) - vars) - (let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) - (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) - (expanded `(multiple-value-bind ,temps - ,(caddr form) - ,@sets)) - (walked (walk-form-internal expanded context env))) - (if (eq walked expanded) - form - walked)) - (walk-template form '(nil (repeat (set)) eval) context env)))) + (variable-symbol-macro-p var env)) + vars) + (let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) + (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) + (expanded `(multiple-value-bind ,temps + ,(caddr form) + ,@sets)) + (walked (walk-form-internal expanded context env))) + (if (eq walked expanded) + form + walked)) + (walk-template form '(nil (repeat (set)) eval) context env)))) (defun walk-multiple-value-bind (form context old-env) (walker-environment-bind (new-env old-env) (let* ((mvb (car form)) - (bindings (second form)) - (mv-form (walk-template (third form) 'EVAL context old-env)) - (body (cdddr form)) - walked-bindings - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) - new-env))) + (bindings (second form)) + (mv-form (walk-template (third form) 'EVAL context old-env)) + (body (cdddr form)) + walked-bindings + (walked-body + (walk-declarations + body + #'(lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) + new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) (defun walk-bindings-1 (bindings old-env new-env context sequentialp) @@ -952,22 +952,22 @@ (prog1 binding (note-lexical-binding binding new-env)) (prog1 (relist* binding - (car binding) - (walk-form-internal (second binding) - context - (if sequentialp - new-env - old-env)) - (cddr binding)) ;save cddr for DO/DO* - ;it is the next value - ;form. Don't walk it - ;now though. + (car binding) + (walk-form-internal (second binding) + context + (if sequentialp + new-env + old-env)) + (cddr binding)) ;save cddr for DO/DO* + ;it is the next value + ;form. Don't walk it + ;now though. (note-lexical-binding (car binding) new-env))) (walk-bindings-1 (cdr bindings) - old-env - new-env - context - sequentialp))))) + old-env + new-env + context + sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context env) (declare (si::c-local)) @@ -975,19 +975,19 @@ (let ((binding (car bindings)) (walked-binding (car walked-bindings))) (recons bindings - (if (symbolp binding) - binding - (relist* binding - (car walked-binding) - (second walked-binding) - (walk-template (cddr binding) - '(EVAL) - context - env))) + (if (symbolp binding) + binding + (relist* binding + (car walked-binding) + (second walked-binding) + (walk-template (cddr binding) + '(EVAL) + context + env))) (walk-bindings-2 (cdr bindings) - (cdr walked-bindings) - context - env))))) + (cdr walked-bindings) + context + env))))) (defun walk-lambda (form context old-env) (walker-environment-bind (new-env old-env) @@ -998,60 +998,60 @@ (walk-declarations body #'walk-repeat-eval new-env))) (relist* form (car form) - walked-arglist + walked-arglist walked-body)))) (defun walk-named-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((name (second form)) - (arglist (third form)) + (arglist (third form)) (body (cdddr form)) (walked-arglist (walk-arglist arglist context new-env)) (walked-body (walk-declarations body #'walk-repeat-eval new-env))) (relist* form (car form) - name - walked-arglist + name + walked-arglist walked-body)))) (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let* ((rforms nil) - (tail (cdr form))) - (loop (when (null tail) (return (nreverse rforms))) - (let ((var (pop tail)) (val (pop tail))) - (push `(setq ,var ,val) rforms))))) - (walked (walk-repeat-eval expanded env))) - (if (eq expanded walked) - form - `(progn ,@walked))) + (tail (cdr form))) + (loop (when (null tail) (return (nreverse rforms))) + (let ((var (pop tail)) (val (pop tail))) + (push `(setq ,var ,val) rforms))))) + (walked (walk-repeat-eval expanded env))) + (if (eq expanded walked) + form + `(progn ,@walked))) (let* ((var (cadr form)) - (val (caddr form)) - (symmac (car (variable-symbol-macro-p var env)))) - (if symmac - (let* ((expanded `(setf ,(cddr symmac) ,val)) - (walked (walk-form-internal expanded context env))) - (if (eq expanded walked) - form - walked)) - (relist form 'setq - (walk-form-internal var :set env) - (walk-form-internal val :eval env)))))) + (val (caddr form)) + (symmac (car (variable-symbol-macro-p var env)))) + (if symmac + (let* ((expanded `(setf ,(cddr symmac) ,val)) + (walked (walk-form-internal expanded context env))) + (if (eq expanded walked) + form + walked)) + (relist form 'setq + (walk-form-internal var :set env) + (walk-form-internal val :eval env)))))) (defun walk-symbol-macrolet (form context old-env) (declare (ignore context)) (let* ((bindings (second form))) (walker-environment-bind - (new-env old-env - :lexical-variables - (append (mapcar #'(lambda (binding) - `(,(first binding) - :macro . ,(second binding))) - bindings) - (env-lexical-variables old-env))) + (new-env old-env + :lexical-variables + (append (mapcar #'(lambda (binding) + `(,(first binding) + :macro . ,(second binding))) + bindings) + (env-lexical-variables old-env))) (relist* form 'SYMBOL-MACROLET bindings - (walk-repeat-eval (cddr form) new-env))))) + (walk-repeat-eval (cddr form) new-env))))) (defun walk-tagbody (form context env) (recons form (car form) (walk-tagbody-1 (cdr form) context env))) @@ -1061,89 +1061,89 @@ (and form (recons form (walk-form-internal (car form) - (if (symbolp (car form)) 'QUOTE context) - env) + (if (symbolp (car form)) 'QUOTE context) + env) (walk-tagbody-1 (cdr form) context env)))) (defun walk-compiler-let (form context old-env) (declare (ignore context)) (let* ((vars ()) - (vals ())) + (vals ())) (dolist (binding (second form)) (cond ((symbolp binding) (push binding vars) (push nil vals)) - (t - (push (car binding) vars) - (push (eval (second binding)) vals)))) + (t + (push (car binding) vars) + (push (eval (second binding)) vals)))) (relist* form - (car form) - (second form) - (progv vars vals (walk-repeat-eval (cddr form) old-env))))) + (car form) + (second form) + (progv vars vals (walk-repeat-eval (cddr form) old-env))))) (defun walk-macrolet (form context old-env) (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) + nil + :walk-function (env-walk-function old-env)) (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions + (and definitions + (let ((definition (car definitions))) + (recons definitions (relist* definition (car definition) (walk-arglist (second definition) - context - macro-env - t) + context + macro-env + t) (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (second form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (relist* form + (car form) + (walk-definitions (second form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-flet (form context old-env) (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context old-env) + (walk-definitions (cdr definitions)))))) (recons form - (car form) - (recons (cdr form) - (walk-definitions (second form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (car form) + (recons (cdr form) + (walk-definitions (second form)) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-labels (form context old-env) (with-new-definition-in-environment (new-env old-env form) (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context new-env) - (walk-definitions (cdr definitions)))))) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) (recons form - (car form) - (recons (cdr form) - (walk-definitions (second form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (car form) + (recons (cdr form) + (walk-definitions (second form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-if (form context env) (let*((predicate (second form)) - (arm1 (third form)) - (arm2 - (if (cddddr form) - (progn - (warn "In the form:~%~S~%~ + (arm1 (third form)) + (arm2 + (if (cddddr form) + (progn + (warn "In the form:~%~S~%~ IF only accepts three arguments, you are using ~D.~%~ It is true that some Common Lisps support this, but ~ it is not~%~ @@ -1152,30 +1152,30 @@ the extra arguments as extra else clauses. ~ Even if this is what~%~ you intended, you should fix your source code." - form - (length (cdr form))) - (cons 'PROGN (cdddr form))) - (fourth form)))) + form + (length (cdr form))) + (cons 'PROGN (cdddr form))) + (fourth form)))) (relist form - 'IF - (walk-form-internal predicate context env) - (walk-form-internal arm1 context env) - (walk-form-internal arm2 context env)))) + 'IF + (walk-form-internal predicate context env) + (walk-form-internal arm1 context env) + (walk-form-internal arm2 context env)))) #+ecl (defun walk-when/unless (form context env) (relist* form - (first form) - (walk-form-internal (second form) context env) ; predicate - (walk-repeat-eval (cddr form) env))) + (first form) + (walk-form-internal (second form) context env) ; predicate + (walk-repeat-eval (cddr form) env))) #+ecl (defun walk-c-inline (form context env) (declare (ignore context)) (relist* form - (first form) - (walk-repeat-eval (second form) env) ; arguments - (cddr form))) ; types and flags of the form + (first form) + (walk-repeat-eval (second form) env) ; arguments + (cddr form))) ; types and flags of the form ;;; ;;; Tests tests tests @@ -1226,8 +1226,8 @@ '(lambda (x y env) (format t "~&Form: ~S ~3T Context: ~A" x y) (when (symbolp x) - (let ((lexical (variable-lexical-p x env)) - (special (variable-special-p x env))) + (let ((lexical (variable-lexical-p x env)) + (special (variable-special-p x env))) (when lexical (format t ";~3T") (format t "lexically bound")) @@ -1277,8 +1277,8 @@ (take-it-out-for-a-test-walk (let ((x 1)) (macrolet ((foo () (list x) ''INNER)) - x - (foo)))) + x + (foo)))) ;;; ;;; A truly hairy use of compiler-let and macrolet. In the body of the @@ -1290,24 +1290,24 @@ (compiler-let ((x 1)) (let ((x 2)) (macrolet ((foo () x)) - x - (foo))))) + x + (foo))))) (take-it-out-for-a-test-walk (flet ((foo (x) (list x y)) - (bar (x) (list x y))) + (bar (x) (list x y))) (foo 1))) (take-it-out-for-a-test-walk (let ((y 2)) (flet ((foo (x) (list x y)) - (bar (x) (list x y))) + (bar (x) (list x y))) (foo 1)))) (take-it-out-for-a-test-walk (labels ((foo (x) (bar x)) - (bar (x) (foo x))) + (bar (x) (foo x))) (foo 1))) (take-it-out-for-a-test-walk @@ -1345,16 +1345,16 @@ (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) (take-it-out-for-a-test-walk (multiple-value-bind (a b) - (foo a b) - (declare (special a)) - (list a b))) + (foo a b) + (declare (special a)) + (list a b))) (take-it-out-for-a-test-walk (progn (function foo))) (take-it-out-for-a-test-walk (progn a b (go a))) (take-it-out-for-a-test-walk (if a b c)) (take-it-out-for-a-test-walk (if a b)) (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) - 1 2)) + 1 2)) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) @@ -1400,13 +1400,13 @@ (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (a) - `(inner-bar-expanded ,a))) + `(inner-bar-expanded ,a))) (bar 2)))) (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (s) - (bar s) - `(inner-bar-expanded ,s))) + (bar s) + `(inner-bar-expanded ,s))) (bar 2)))) (take-it-out-for-a-test-walk (cond (a b) @@ -1415,17 +1415,17 @@ (let ((the-lexical-variables ())) (walk-form '(let ((a 1) (b 2)) - #'(lambda (x) (list a b x y))) - () - #'(lambda (form context env) - (when (and (symbolp form) - (variable-lexical-p form env)) - (push form the-lexical-variables)) - form)) + #'(lambda (x) (list a b x y))) + () + #'(lambda (form context env) + (when (and (symbolp form) + (variable-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) - (member 'x the-lexical-variables)) + (member 'a the-lexical-variables) + (member 'b the-lexical-variables) + (member 'x the-lexical-variables)) (error "Walker didn't do lexical variables of a closure properly."))) |# diff --git a/src/clx/attributes.lisp b/src/clx/attributes.lisp index edb42e40b..07d6376ea 100644 --- a/src/clx/attributes.lisp +++ b/src/clx/attributes.lisp @@ -3,9 +3,9 @@ ;;; Window Attributes ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -18,27 +18,27 @@ ;;; express or implied warranty. ;;; -;;; The special variable *window-attributes* is an alist containg: -;;; (drawable attributes attribute-changes geometry geometry-changes) -;;; Where DRAWABLE is the associated window or pixmap -;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's -;;; attributes for use by the accessors. -;;; ATTRIBUTE-CHANGES is NIL or an array. The first element -;;; of the array is a "value-mask", indicating which -;;; attributes have changed. The other elements are -;;; integers associated with the changed values, ready -;;; for insertion into a server request. -;;; GEOMETRY is like ATTRIBUTES, but for window geometry -;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry +;;; The special variable *window-attributes* is an alist containg: +;;; (drawable attributes attribute-changes geometry geometry-changes) +;;; Where DRAWABLE is the associated window or pixmap +;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's +;;; attributes for use by the accessors. +;;; ATTRIBUTE-CHANGES is NIL or an array. The first element +;;; of the array is a "value-mask", indicating which +;;; attributes have changed. The other elements are +;;; integers associated with the changed values, ready +;;; for insertion into a server request. +;;; GEOMETRY is like ATTRIBUTES, but for window geometry +;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry ;;; -;;; Attribute and Geometry accessors and SETF's look on the special variable -;;; *window-attributes* for the drawable. If its not there, the accessor is +;;; Attribute and Geometry accessors and SETF's look on the special variable +;;; *window-attributes* for the drawable. If its not there, the accessor is ;;; NOT within a WITH-STATE, and a server request is made to get or put a value. ;;; If an entry is found in *window-attributes*, the cache buffers are used -;;; for the access. +;;; for the access. ;;; -;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including -;;; the new drawable. The caches are initialized to NIL and allocated as needed. +;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including +;;; the new drawable. The caches are initialized to NIL and allocated as needed. (in-package :xlib) @@ -114,9 +114,9 @@ ;; alist of (drawable attributes attribute-changes geometry geometry-changes) `(with-stack-list (,state-entry ,drawable nil nil nil nil) (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) - (multiple-value-prog1 - (progn ,@body) - (cleanup-state-entry ,state-entry)))))) + (multiple-value-prog1 + (progn ,@body) + (cleanup-state-entry ,state-entry)))))) (defun cleanup-state-entry (state) ;; Return buffers to the free-list @@ -139,25 +139,25 @@ ;; Called from window attribute SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type window window) - (type card8 number) - (type card32 value)) + (type card8 number) + (type card32 value)) (let ((state-entry nil) - (changes nil)) + (changes nil)) (if (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-attribute-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-attribute-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server + (setq state-entry (assoc window (the list *window-attributes*) + :test (window-equal-function)))) + (progn ; Within a WITH-STATE - cache changes + (setq changes (state-attribute-changes state-entry)) + (unless changes + (setq changes (allocate-gcontext-state)) + (setf (state-attribute-changes state-entry) changes) + (setf (aref changes 0) 0)) ;; Initialize mask to zero + (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit + (setf (aref changes (1+ number)) value)) ;; save value + ; Send change to the server (with-buffer-request ((window-display window) +x-changewindowattributes+) - (window window) - (card32 (ash 1 number) value))))) + (window window) + (card32 (ash 1 number) value))))) ;; ;; These two are twins (change-window-attribute change-drawable-geometry) ;; If you change one, you probably need to change the other... @@ -166,52 +166,52 @@ ;; Called from drawable geometry SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type drawable drawable) - (type card8 number) - (type card29 value)) + (type card8 number) + (type card29 value)) (let ((state-entry nil) - (changes nil)) + (changes nil)) (if (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function)))) - (progn ; Within a WITH-STATE - cache changes - (setq changes (state-geometry-changes state-entry)) - (unless changes - (setq changes (allocate-gcontext-state)) - (setf (state-geometry-changes state-entry) changes) - (setf (aref changes 0) 0)) ;; Initialize mask to zero - (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit - (setf (aref changes (1+ number)) value)) ;; save value - ; Send change to the server + (setq state-entry (assoc drawable (the list *window-attributes*) + :test (drawable-equal-function)))) + (progn ; Within a WITH-STATE - cache changes + (setq changes (state-geometry-changes state-entry)) + (unless changes + (setq changes (allocate-gcontext-state)) + (setf (state-geometry-changes state-entry) changes) + (setf (aref changes 0) 0)) ;; Initialize mask to zero + (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit + (setf (aref changes (1+ number)) value)) ;; save value + ; Send change to the server (with-buffer-request ((drawable-display drawable) +x-configurewindow+) - (drawable drawable) - (card16 (ash 1 number)) - (card29 value))))) + (drawable drawable) + (card16 (ash 1 number)) + (card29 value))))) (defun get-window-attributes-buffer (window) (declare (type window window)) (let ((state-entry nil) - (changes nil)) + (changes nil)) (or (and *window-attributes* - (setq state-entry (assoc window (the list *window-attributes*) - :test (window-equal-function))) - (null (setq changes (state-attribute-changes state-entry))) - (state-attributes state-entry)) - (let ((display (window-display window))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-window-attribute-changes window changes) - (deallocate-gcontext-state (state-attribute-changes state-entry)) - (setf (state-attribute-changes state-entry) nil)) - ;; Get window attributes - (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) - ((window window)) - (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-attributes state-entry) repbuf)) - repbuf))))))) + (setq state-entry (assoc window (the list *window-attributes*) + :test (window-equal-function))) + (null (setq changes (state-attribute-changes state-entry))) + (state-attributes state-entry)) + (let ((display (window-display window))) + (with-display (display) + ;; When SETF's have been done, flush changes to the server + (when changes + (put-window-attribute-changes window changes) + (deallocate-gcontext-state (state-attribute-changes state-entry)) + (setf (state-attribute-changes state-entry) nil)) + ;; Get window attributes + (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) + ((window window)) + (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) + (declare (type reply-buffer repbuf)) + ;; Copy into repbuf from reply buffer + (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) + (when state-entry (setf (state-attributes state-entry) repbuf)) + repbuf))))))) ;; ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) @@ -220,52 +220,52 @@ (defun get-drawable-geometry-buffer (drawable) (declare (type drawable drawable)) (let ((state-entry nil) - (changes nil)) + (changes nil)) (or (and *window-attributes* - (setq state-entry (assoc drawable (the list *window-attributes*) - :test (drawable-equal-function))) - (null (setq changes (state-geometry-changes state-entry))) - (state-geometry state-entry)) - (let ((display (drawable-display drawable))) - (with-display (display) - ;; When SETF's have been done, flush changes to the server - (when changes - (put-drawable-geometry-changes drawable changes) - (deallocate-gcontext-state (state-geometry-changes state-entry)) - (setf (state-geometry-changes state-entry) nil)) - ;; Get drawable attributes - (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) - ((drawable drawable)) - (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) - (declare (type reply-buffer repbuf)) - ;; Copy into repbuf from reply buffer - (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) - (when state-entry (setf (state-geometry state-entry) repbuf)) - repbuf))))))) + (setq state-entry (assoc drawable (the list *window-attributes*) + :test (drawable-equal-function))) + (null (setq changes (state-geometry-changes state-entry))) + (state-geometry state-entry)) + (let ((display (drawable-display drawable))) + (with-display (display) + ;; When SETF's have been done, flush changes to the server + (when changes + (put-drawable-geometry-changes drawable changes) + (deallocate-gcontext-state (state-geometry-changes state-entry)) + (setf (state-geometry-changes state-entry) nil)) + ;; Get drawable attributes + (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) + ((drawable drawable)) + (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) + (declare (type reply-buffer repbuf)) + ;; Copy into repbuf from reply buffer + (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) + (when state-entry (setf (state-geometry state-entry) repbuf)) + repbuf))))))) (defun put-window-attribute-changes (window changes) ;; change window attributes ;; Always from Called within a WITH-DISPLAY (declare (type window window) - (type gcontext-state changes)) + (type gcontext-state changes)) (let* ((display (window-display window)) - (mask (aref changes 0))) + (mask (aref changes 0))) (declare (type display display) - (type mask32 mask)) + (type mask32 mask)) (with-buffer-request (display +x-changewindowattributes+) (window window) (card32 mask) (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (index-incf request-size)) - (index-incf (buffer-boffset display) (index* request-size 4))) - (declare (type mask32 bits) - (type array-index i request-size)) - (when (oddp bits) - (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) + (do ((bits mask (ash bits -1)) + (request-size 2) ;Word count + (i 1 (index+ i 1))) ;Entry count + ((zerop bits) + (card16-put 2 (index-incf request-size)) + (index-incf (buffer-boffset display) (index* request-size 4))) + (declare (type mask32 bits) + (type array-index i request-size)) + (when (oddp bits) + (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) ;; ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) ;; If you change one, you probably need to change the other... @@ -274,26 +274,26 @@ ;; change window attributes or geometry (depending on request-number...) ;; Always from Called within a WITH-DISPLAY (declare (type window window) - (type gcontext-state changes)) + (type gcontext-state changes)) (let* ((display (window-display window)) - (mask (aref changes 0))) + (mask (aref changes 0))) (declare (type display display) - (type mask16 mask)) + (type mask16 mask)) (with-buffer-request (display +x-configurewindow+) (window window) (card16 mask) (progn ;; Insert a word in the request for each one bit in the mask - (do ((bits mask (ash bits -1)) - (request-size 2) ;Word count - (i 1 (index+ i 1))) ;Entry count - ((zerop bits) - (card16-put 2 (incf request-size)) - (index-incf (buffer-boffset display) (* request-size 4))) - (declare (type mask16 bits) - (type fixnum request-size) - (type array-index i)) - (when (oddp bits) - (card29-put (* (incf request-size) 4) (aref changes i)))))))) + (do ((bits mask (ash bits -1)) + (request-size 2) ;Word count + (i 1 (index+ i 1))) ;Entry count + ((zerop bits) + (card16-put 2 (incf request-size)) + (index-incf (buffer-boffset display) (* request-size 4))) + (declare (type mask16 bits) + (type fixnum request-size) + (type array-index i)) + (when (oddp bits) + (card29-put (* (incf request-size) 4) (aref changes i)))))))) (defmacro with-attributes ((window &rest options) &body body) `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) @@ -301,7 +301,7 @@ (prog1 (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) (unless *window-attributes* - (deallocate-context .with-attributes-reply-buffer.))))) + (deallocate-context .with-attributes-reply-buffer.))))) ;; ;; These two are twins (with-attributes with-geometry) ;; If you change one, you probably need to change the other... @@ -312,7 +312,7 @@ (prog1 (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) (unless *window-attributes* - (deallocate-context .with-geometry-reply-buffer.))))) + (deallocate-context .with-geometry-reply-buffer.))))) ;;;----------------------------------------------------------------------------- ;;; Group A: (for GetWindowAttributes) @@ -338,15 +338,15 @@ (defun set-window-background (window background) (declare (type window window) - (type (or (member :none :parent-relative) pixel pixmap) background)) + (type (or (member :none :parent-relative) pixel pixmap) background)) (cond ((eq background :none) (change-window-attribute window 0 0)) - ((eq background :parent-relative) (change-window-attribute window 0 1)) - ((integerp background) ;; Background pixel - (change-window-attribute window 0 0) ;; pixmap :NONE - (change-window-attribute window 1 background)) - ((type? background 'pixmap) ;; Background pixmap - (change-window-attribute window 0 (pixmap-id background))) - (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) + ((eq background :parent-relative) (change-window-attribute window 0 1)) + ((integerp background) ;; Background pixel + (change-window-attribute window 0 0) ;; pixmap :NONE + (change-window-attribute window 1 background)) + ((type? background 'pixmap) ;; Background pixmap + (change-window-attribute window 0 (pixmap-id background))) + (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) background) #+Genera (eval-when (compile) (compiler:function-defined 'window-background)) @@ -355,13 +355,13 @@ (defun set-window-border (window border) (declare (type window window) - (type (or (member :copy) pixel pixmap) border)) + (type (or (member :copy) pixel pixmap) border)) (cond ((eq border :copy) (change-window-attribute window 2 0)) - ((type? border 'pixmap) ;; Border pixmap - (change-window-attribute window 2 (pixmap-id border))) - ((integerp border) ;; Border pixel - (change-window-attribute window 3 border)) - (t (x-type-error border '(or (member :copy) integer pixmap)))) + ((type? border 'pixmap) ;; Border pixmap + (change-window-attribute window 2 (pixmap-id border))) + ((integerp border) ;; Border pixel + (change-window-attribute window 3 border)) + (t (x-type-error border '(or (member :copy) integer pixmap)))) border) #+Genera (eval-when (compile) (compiler:function-defined 'window-border)) @@ -496,12 +496,12 @@ (with-attributes (window :sizes 32) (let ((id (resource-id-get 28))) (if (zerop id) - nil - (let ((colormap (lookup-colormap (window-display window) id))) - (unless (colormap-visual-info colormap) - (setf (colormap-visual-info colormap) - (visual-info (window-display window) (resource-id-get 8)))) - colormap))))) + nil + (let ((colormap (lookup-colormap (window-display window) id))) + (unless (colormap-visual-info colormap) + (setf (colormap-visual-info colormap) + (visual-info (window-display window) (resource-id-get 8)))) + colormap))))) (defun set-window-colormap (window colormap) (change-window-attribute @@ -627,8 +627,8 @@ (defun set-window-priority (mode window sibling) (declare (type (member :above :below :top-if :bottom-if :opposite) mode) - (type window window) - (type (or null window) sibling)) + (type window window) + (type (or null window) sibling)) (with-state (window) (change-drawable-geometry window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) diff --git a/src/clx/big-requests.lisp b/src/clx/big-requests.lisp index ea5665145..4f369b598 100644 --- a/src/clx/big-requests.lisp +++ b/src/clx/big-requests.lisp @@ -25,7 +25,7 @@ (declare (type display display)) (let ((opcode (extension-opcode display "BIG-REQUESTS"))) (with-buffer-request-and-reply (display opcode nil) - ((data 0)) + ((data 0)) (let ((maximum-request-length (card32-get 8))) - (setf (display-extended-max-request-length display) - maximum-request-length))))) + (setf (display-extended-max-request-length display) + maximum-request-length))))) diff --git a/src/clx/buffer.lisp b/src/clx/buffer.lisp index c48897399..9a0214d5b 100644 --- a/src/clx/buffer.lisp +++ b/src/clx/buffer.lisp @@ -4,9 +4,9 @@ ;;; windows version 11 ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -57,43 +57,43 @@ ;;; compiled without macros and bufmac being loaded. (defmacro with-buffer ((buffer &key timeout inline) - &body body &environment env) + &body body &environment env) ;; This macro is for use in a multi-process environment. It provides ;; exclusive access to the local buffer object for request generation and ;; reply processing. `(macrolet ((with-buffer ((buffer &key timeout) &body body) - ;; Speedup hack for lexically nested with-buffers - `(progn - (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) + ;; Speedup hack for lexically nested with-buffers + `(progn + (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-buffer-body.)) - (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) - (let ((buf (if (or (symbolp buffer) (constantp buffer)) - buffer - '.buffer.))) - `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) - ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) - ,(declare-bufmac) - (when (buffer-dead ,buf) - (x-error 'closed-display :display ,buf)) - (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) + `(flet ((.with-buffer-body. () ,@body)) + #+clx-ansi-common-lisp + (declare (dynamic-extent #'.with-buffer-body.)) + (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) + (let ((buf (if (or (symbolp buffer) (constantp buffer)) + buffer + '.buffer.))) + `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) + ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) + ,(declare-bufmac) + (when (buffer-dead ,buf) + (x-error 'closed-display :display ,buf)) + (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" + ,@(and timeout `(:timeout ,timeout))) + ,@body)))))) (defun with-buffer-function (buffer timeout function) (declare (type display buffer) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - ;; FIXME: This is probably more a bug in SBCL (logged as - ;; bug #243) - (ignorable timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (type (or null number) timeout) + (type function function) + #+clx-ansi-common-lisp + (dynamic-extent function) + ;; FIXME: This is probably more a bug in SBCL (logged as + ;; bug #243) + (ignorable timeout) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg function)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) @@ -150,54 +150,54 @@ `(with-buffer-input (,event ,@options) ,@body)) (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) - &body body) + &body body) (unless (listp sizes) (setq sizes (list sizes))) ;; 160 is a special hack for client-message-events (when (set-difference sizes '(0 8 16 32 160 256)) (error "Illegal sizes in ~a" sizes)) `(let ((%reply-buffer ,reply-buffer) - ,@(and display `((%buffer ,display)))) + ,@(and display `((%buffer ,display)))) (declare (type reply-buffer %reply-buffer) - ,@(and display '((type display %buffer)))) + ,@(and display '((type display %buffer)))) ,(declare-bufmac) ,@(and display '(%buffer)) (let* ((buffer-boffset (the array-index ,(or index 0))) - #-clx-overlapping-arrays - (buffer-bbuf (reply-ibuf8 %reply-buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (reply-ibuf16 %reply-buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) + #-clx-overlapping-arrays + (buffer-bbuf (reply-ibuf8 %reply-buffer)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) + (when (or (member 16 sizes) (member 160 sizes)) + `((buffer-woffset (index-ash buffer-boffset -1)) + (buffer-wbuf (reply-ibuf16 %reply-buffer)))) + (when (member 32 sizes) + `((buffer-loffset (index-ash buffer-boffset -2)) + (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) + (when (member 8 sizes) + '((declare (type buffer-bytes buffer-bbuf)))) + (when (member 16 sizes) + '((declare (type array-index buffer-woffset)) + (declare (type buffer-words buffer-wbuf)))) + (when (member 32 sizes) + '((declare (type array-index buffer-loffset)) + (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) + (when (member 8 sizes) '(buffer-bbuf)) + (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) + (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) - ,@body) + ,@body) #-clx-overlapping-arrays ,@body))) @@ -205,28 +205,28 @@ (declare (dynamic-extent options)) ;; Output-Size is the output-buffer size in bytes. (let ((byte-output (make-array output-size :element-type 'card8 - :initial-element 0))) + :initial-element 0))) (apply constructor - :size output-size - :obuf8 byte-output - #+clx-overlapping-arrays - :obuf16 - #+clx-overlapping-arrays - (make-array (index-ash output-size -1) - :element-type 'overlap16 - :displaced-to byte-output) - #+clx-overlapping-arrays - :obuf32 - #+clx-overlapping-arrays - (make-array (index-ash output-size -2) - :element-type 'overlap32 - :displaced-to byte-output) - options))) + :size output-size + :obuf8 byte-output + #+clx-overlapping-arrays + :obuf16 + #+clx-overlapping-arrays + (make-array (index-ash output-size -1) + :element-type 'overlap16 + :displaced-to byte-output) + #+clx-overlapping-arrays + :obuf32 + #+clx-overlapping-arrays + (make-array (index-ash output-size -2) + :element-type 'overlap32 + :displaced-to byte-output) + options))) (defun make-reply-buffer (size) ;; Size is the buffer size in bytes (let ((byte-input (make-array size :element-type 'card8 - :initial-element 0))) + :initial-element 0))) (make-reply-buffer-internal :size size :ibuf8 byte-input @@ -234,41 +234,41 @@ :ibuf16 #+clx-overlapping-arrays (make-array (index-ash size -1) - :element-type 'overlap16 - :displaced-to byte-input) + :element-type 'overlap16 + :displaced-to byte-input) #+clx-overlapping-arrays :ibuf32 #+clx-overlapping-arrays (make-array (index-ash size -2) - :element-type 'overlap32 - :displaced-to byte-input)))) + :element-type 'overlap32 + :displaced-to byte-input)))) (defun buffer-ensure-size (buffer size) (declare (type buffer buffer) - (type array-index size)) + (type array-index size)) (when (index> size (buffer-size buffer)) (with-buffer (buffer) (buffer-flush buffer) (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) - (new-buffer (make-array new-buffer-size :element-type 'card8 - :initial-element 0))) - (setf (buffer-obuf8 buffer) new-buffer) - #+clx-overlapping-arrays - (setf (buffer-obuf16 buffer) - (make-array (index-ash new-buffer-size -1) - :element-type 'overlap16 - :displaced-to new-buffer) - (buffer-obuf32 buffer) - (make-array (index-ash new-buffer-size -2) - :element-type 'overlap32 - :displaced-to new-buffer)))))) + (new-buffer (make-array new-buffer-size :element-type 'card8 + :initial-element 0))) + (setf (buffer-obuf8 buffer) new-buffer) + #+clx-overlapping-arrays + (setf (buffer-obuf16 buffer) + (make-array (index-ash new-buffer-size -1) + :element-type 'overlap16 + :displaced-to new-buffer) + (buffer-obuf32 buffer) + (make-array (index-ash new-buffer-size -2) + :element-type 'overlap32 + :displaced-to new-buffer)))))) (defun buffer-pad-request (buffer pad) (declare (type buffer buffer) - (type array-index pad)) + (type array-index pad)) (unless (index-zerop pad) (when (index> (index+ (buffer-boffset buffer) pad) - (buffer-size buffer)) + (buffer-size buffer)) (buffer-flush buffer)) (incf (buffer-boffset buffer) pad) (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) @@ -279,31 +279,31 @@ (defun buffer-new-request-number (buffer) (declare (type buffer buffer)) (setf (buffer-request-number buffer) - (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) + (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) (defun with-buffer-request-function (display gc-force request-function) (declare (type display display) - (type (or null gcontext) gc-force)) + (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn - (when gc-force (force-gcontext-changes-internal gc-force)) - (without-aborts (funcall request-function display))) + (when gc-force (force-gcontext-changes-internal gc-force)) + (without-aborts (funcall request-function display))) (display-invoke-after-function display)))) (defun with-buffer-request-function-nolock (display gc-force request-function) (declare (type display display) - (type (or null gcontext) gc-force)) + (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + #+clx-ansi-common-lisp + (dynamic-extent request-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) @@ -319,31 +319,31 @@ (defun with-buffer-request-and-reply-function (display multiple-reply request-function reply-function) (declare (type display display) - (type generalized-boolean multiple-reply)) + (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) + #+clx-ansi-common-lisp + (dynamic-extent request-function reply-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg request-function reply-function)) (let ((pending-command nil) - (reply-buffer nil)) + (reply-buffer nil)) (declare (type (or null pending-command) pending-command) - (type (or null reply-buffer) reply-buffer)) + (type (or null reply-buffer) reply-buffer)) (unwind-protect - (progn - (with-buffer (display :inline t) - (setq pending-command (start-pending-command display)) - (without-aborts (funcall request-function display)) - (buffer-force-output display) - (display-invoke-after-function display)) - (cond (multiple-reply - (loop - (setq reply-buffer (read-reply display pending-command)) - (when (funcall reply-function display reply-buffer) (return nil)) - (deallocate-reply-buffer (shiftf reply-buffer nil)))) - (t - (setq reply-buffer (read-reply display pending-command)) - (funcall reply-function display reply-buffer)))) + (progn + (with-buffer (display :inline t) + (setq pending-command (start-pending-command display)) + (without-aborts (funcall request-function display)) + (buffer-force-output display) + (display-invoke-after-function display)) + (cond (multiple-reply + (loop + (setq reply-buffer (read-reply display pending-command)) + (when (funcall reply-function display reply-buffer) (return nil)) + (deallocate-reply-buffer (shiftf reply-buffer nil)))) + (t + (setq reply-buffer (read-reply display pending-command)) + (funcall reply-function display reply-buffer)))) (when reply-buffer (deallocate-reply-buffer reply-buffer)) (when pending-command (stop-pending-command display pending-command))))) @@ -355,7 +355,7 @@ ;; Write out VECTOR from START to END into BUFFER ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER (declare (type buffer buffer) - (type array-index start end)) + (type array-index start end)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (wrap-buf-output (buffer) @@ -370,20 +370,20 @@ (let ((boffset (buffer-boffset buffer))) (declare (type array-index boffset)) (when (index-plusp boffset) - (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) - (setf (buffer-boffset buffer) 0) - (setf (buffer-last-request buffer) nil)))) + (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) + (setf (buffer-boffset buffer) 0) + (setf (buffer-last-request buffer) nil)))) nil) (defmacro with-buffer-flush-inhibited ((buffer) &body body) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) - (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) + (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) (unwind-protect - (progn - (setf (buffer-flush-inhibit ,buf) t) - ,@body) - (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) + (progn + (setf (buffer-flush-inhibit ,buf) t) + ,@body) + (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) (defun buffer-force-output (buffer) ;; Output is normally buffered, this forces any buffered output to the server. @@ -415,19 +415,19 @@ ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) - (type vector vector) - (type array-index start end) - (type (or null number) timeout)) + (type vector vector) + (type array-index start end) + (type (or null number) timeout)) (declare (clx-values eof-p)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (unless (= start end) (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-function buffer) - buffer vector start end timeout)))) + (wrap-buf-input (buffer) + (funcall (buffer-input-function buffer) + buffer vector start end timeout)))) (unless (or (null result) (eq result :timeout)) - (close-buffer buffer)) + (close-buffer buffer)) result))) (defun buffer-input-wait (buffer timeout) @@ -435,14 +435,14 @@ ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) - (type (or null number) timeout)) + (type (or null number) timeout)) (declare (clx-values timeout)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (let ((result - (wrap-buf-input (buffer) - (funcall (buffer-input-wait-function buffer) - buffer timeout)))) + (wrap-buf-input (buffer) + (funcall (buffer-input-wait-function buffer) + buffer timeout)))) (unless (or (null result) (eq result :timeout)) (close-buffer buffer)) result)) @@ -454,35 +454,35 @@ (declare (clx-values input-available)) (or (not (null (buffer-dead buffer))) (wrap-buf-input (buffer) - (funcall (buffer-listen-function buffer) buffer)))) + (funcall (buffer-listen-function buffer) buffer)))) ;;; Reading sequences of strings ;;; a list of pascal-strings with card8 lengths, no padding in between ;;; can't use read-sequence-char (defun read-sequence-string (buffer-bbuf length nitems result-type - &optional (buffer-boffset 0)) + &optional (buffer-boffset 0)) (declare (type buffer-bytes buffer-bbuf) - (type array-index length nitems buffer-boffset)) + (type array-index length nitems buffer-boffset)) length (with-vector (buffer-bbuf buffer-bytes) (let ((result (make-sequence result-type nitems))) (do* ((index 0 (index+ index 1 string-length)) - (count 0 (index1+ count)) - (string-length 0) - (string "")) - ((index>= count nitems) - result) - (declare (type array-index index count string-length) - (type string string)) - (setq string-length (read-card8 index) - string (make-sequence 'string string-length)) - (do ((i (index1+ index) (index1+ i)) - (j 0 (index1+ j))) - ((index>= j string-length) - (setf (elt result count) string)) - (declare (type array-index i j)) - (setf (aref string j) (card8->char (read-card8 i)))))))) + (count 0 (index1+ count)) + (string-length 0) + (string "")) + ((index>= count nitems) + result) + (declare (type array-index index count string-length) + (type string string)) + (setq string-length (read-card8 index) + string (make-sequence 'string string-length)) + (do ((i (index1+ index) (index1+ i)) + (j 0 (index1+ j))) + ((index>= j string-length) + (setf (elt result count) string)) + (declare (type array-index i j)) + (setf (aref string j) (card8->char (read-card8 i)))))))) ;;; Reading sequences of chars @@ -498,10 +498,10 @@ #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform - (flet ((,ntrans (v) (funcall transform (,transformer v)))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,reader reply-buffer result-type nitems #',ntrans data start index)) - (,reader reply-buffer result-type nitems #',transformer data start index))))) + (flet ((,ntrans (v) (funcall transform (,transformer v)))) + #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (,reader reply-buffer result-type nitems #',ntrans data start index)) + (,reader reply-buffer result-type nitems #',transformer data start index))))) (define-transformed-sequence-reader read-sequence-char character card8->char read-sequence-card8) @@ -512,29 +512,29 @@ `(progn (defun ,name (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data)) + (type array-index nitems start index) + (type list data)) (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (,reader index))))) + (do* ((j nitems (index- j 1)) + (list (nthcdr start data) (cdr list)) + (index 0 (index+ index ,step))) + ((index-zerop j)) + (declare (type array-index index j) (type list list)) + (setf (car list) (,reader index))))) (defun ,tname (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type list data) - (type (function (,type) t) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (type array-index nitems start index) + (type list data) + (type (function (,type) t) transform) + #+clx-ansi-common-lisp (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-buffer-input (reply-buffer :sizes (,size) :index index) - (do* ((j nitems (index- j 1)) - (list (nthcdr start data) (cdr list)) - (index 0 (index+ index ,step))) - ((index-zerop j)) - (declare (type array-index index j) (type list list)) - (setf (car list) (funcall transform (,reader index)))))))) + (do* ((j nitems (index- j 1)) + (list (nthcdr start data) (cdr list)) + (index 0 (index+ index ,step))) + ((index-zerop j)) + (declare (type array-index index j) (type list list)) + (setf (car list) (funcall transform (,reader index)))))))) (define-list-readers (read-list-card8 read-list-card8-with-transform) card8 8 1 read-card8) @@ -542,8 +542,8 @@ #-lispm (defun read-simple-array-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) + (type array-index nitems start index) + (type (simple-array card8 (*)) data)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8)) (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) @@ -551,54 +551,54 @@ #-lispm (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card8 (*)) data)) + (type array-index nitems start index) + (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) + (end (index+ start nitems)) + (index 0 (index+ index 1))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) (defun read-vector-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card8 index)))))) + (end (index+ start nitems)) + (index 0 (index+ index 1))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (read-card8 index)))))) (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 1))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card8 index))))))) + (end (index+ start nitems)) + (index 0 (index+ index 1))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (funcall transform (read-card8 index))))))) (defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) @@ -612,20 +612,20 @@ #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (let ((result (or data (make-sequence result-type nitems)))) (typecase result - (list - (if transform - (,tlist reply-buffer nitems result transform start index) - (,list reply-buffer nitems result start index))) - #-lispm - ((simple-array ,type (*)) - (if transform - (,tsa reply-buffer nitems result transform start index) - (,sa reply-buffer nitems result start index))) - ;; FIXME: general sequences - (t - (if transform - (,tvec reply-buffer nitems result transform start index) - (,vec reply-buffer nitems result start index)))) + (list + (if transform + (,tlist reply-buffer nitems result transform start index) + (,list reply-buffer nitems result start index))) + #-lispm + ((simple-array ,type (*)) + (if transform + (,tsa reply-buffer nitems result transform start index) + (,sa reply-buffer nitems result start index))) + ;; FIXME: general sequences + (t + (if transform + (,tvec reply-buffer nitems result transform start index) + (,vec reply-buffer nitems result start index)))) result))) (define-sequence-reader read-sequence-card8 card8 @@ -644,74 +644,74 @@ #-lispm (defun read-simple-array-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) + (type array-index nitems start index) + (type (simple-array card16 (*)) data)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (read-card16 index)))) + (end (index+ start nitems)) + (index 0 (index+ index 2))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (the card16 (read-card16 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) #-lispm (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card16 (*)) data)) + (type array-index nitems start index) + (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) + (end (index+ start nitems)) + (index 0 (index+ index 2))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) (defun read-vector-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card16 index))) + (end (index+ start nitems)) + (index 0 (index+ index 2))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (read-card16 index))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 2))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card16 index))))))) + (end (index+ start nitems)) + (index 0 (index+ index 2))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (funcall transform (read-card16 index))))))) (define-sequence-reader read-sequence-card16 card16 (read-list-card16 read-list-card16-with-transform) @@ -729,74 +729,74 @@ #-lispm (defun read-simple-array-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) + (type array-index nitems start index) + (type (simple-array card32 (*)) data)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (read-card32 index)))) + (end (index+ start nitems)) + (index 0 (index+ index 4))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (the card32 (read-card32 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) #-lispm (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type (simple-array card32 (*)) data)) + (type array-index nitems start index) + (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) + (end (index+ start nitems)) + (index 0 (index+ index 4))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) (defun read-vector-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (read-card32 index))) + (end (index+ start nitems)) + (index 0 (index+ index 4))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (read-card32 index))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) - (type array-index nitems start index) - (type vector data) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type array-index nitems start index) + (type vector data) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) - (end (index+ start nitems)) - (index 0 (index+ index 4))) - ((index>= j end)) - (declare (type array-index j end index)) - (setf (aref data j) (funcall transform (read-card32 index))))))) + (end (index+ start nitems)) + (index 0 (index+ index 4))) + ((index>= j end)) + (declare (type array-index j end index)) + (setf (aref data j) (funcall transform (read-card32 index))))))) (define-sequence-reader read-sequence-card32 card32 (read-list-card32 read-list-card32-with-transform) @@ -819,10 +819,10 @@ #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform - (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) - (,writer buffer boffset data start end #',ntrans)) - (,writer buffer boffset data start end #',transformer))))) + (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) + #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (,writer buffer boffset data start end #',ntrans)) + (,writer buffer boffset data start end #',transformer))))) (define-transformed-sequence-writer write-sequence-char character char->card8 write-sequence-card8) @@ -837,12 +837,12 @@ (type list data) (type array-index boffset start end)) (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (pop list))))) + ((list (nthcdr start data))) + ((type list list)) + (do ((j 0 (index+ j ,step))) + ((index>= j chunk)) + (declare (type array-index j)) + (,writer j (pop list))))) (defun ,tname (buffer boffset data start end transform) (declare (type buffer buffer) @@ -852,29 +852,29 @@ #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (writing-buffer-chunks ,type - ((list (nthcdr start data))) - ((type list list)) - (do ((j 0 (index+ j ,step))) - ((index>= j chunk)) - (declare (type array-index j)) - (,writer j (funcall transform (pop list)))))))) + ((list (nthcdr start data))) + ((type list list)) + (do ((j 0 (index+ j ,step))) + ((index>= j chunk)) + (declare (type array-index j)) + (,writer j (funcall transform (pop list)))))))) ;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 #+ti (progn (defun write-list-card8 (buffer boffset data start end) (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list list)) + ((list (nthcdr start data))) + ((type list list)) (dotimes (j chunk) - (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) + (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) (defun write-list-card8-with-transform (buffer boffset data start end transform) (writing-buffer-chunks card8 - ((list (nthcdr start data))) - ((type list lst)) + ((list (nthcdr start data))) + ((type list lst)) (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (pop lst))))))) + (declare (type array-index j)) + (write-card8 j (funcall transform (pop lst))))))) #-ti (define-list-writers (write-list-card8 write-list-card8-with-transform) card8 @@ -884,70 +884,70 @@ #-lispm (defun write-simple-array-card8 (buffer boffset data start end) (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) + (type (simple-array card8 (*)) data) + (type array-index boffset start end)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 - ((index start (index+ index chunk))) - ((type array-index index)) + ((index start (index+ index chunk))) + ((type array-index index)) (buffer-replace buffer-bbuf data - buffer-boffset - (index+ buffer-boffset chunk) - index))) + buffer-boffset + (index+ buffer-boffset chunk) + index))) nil) #-lispm (defun write-simple-array-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type (simple-array card8 (*)) data) - (type array-index boffset start end)) + (type (simple-array card8 (*)) data) + (type array-index boffset start end)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + (declare (type array-index j)) + (write-card8 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defun write-vector-card8 (buffer boffset data start end) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (aref data index)) - (setq index (index+ index 1))))) + (declare (type array-index j)) + (write-card8 j (aref data index)) + (setq index (index+ index 1))))) nil) (defun write-vector-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end)) + (type vector data) + (type array-index boffset start end)) (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card8 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (dotimes (j chunk) - (declare (type array-index j)) - (write-card8 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + (declare (type array-index j)) + (write-card8 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) @@ -962,17 +962,17 @@ (typecase data (list (if transform - (,tlist buffer boffset data start end transform) - (,list buffer boffset data start end))) + (,tlist buffer boffset data start end transform) + (,list buffer boffset data start end))) #-lispm ((simple-array ,type (*)) (if transform - (,tsa buffer boffset data start end transform) - (,sa buffer boffset data start end))) + (,tsa buffer boffset data start end transform) + (,sa buffer boffset data start end))) (t ; FIXME: general sequences (if transform - (,tvec buffer boffset data start end transform) - (,vec buffer boffset data start end)))))) + (,tvec buffer boffset data start end transform) + (,vec buffer boffset data start end)))))) (define-sequence-writer write-sequence-card8 card8 (write-list-card8 write-list-card8-with-transform) @@ -990,93 +990,93 @@ #-lispm (defun write-simple-array-card16 (buffer boffset data start end) (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) + (type (simple-array card16 (*)) data) + (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card16 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-wbuf data + buffer-woffset + (index+ buffer-woffset length) + index) + (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) + (type (simple-array card16 (*)) data) + (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card16 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defun write-vector-card16 (buffer boffset data start end) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card16 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-wbuf data + buffer-woffset + (index+ buffer-woffset length) + index) + (setq index (index+ index length))))) nil) (defun write-vector-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card16 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card16 card16 @@ -1092,93 +1092,93 @@ #-lispm (defun write-simple-array-int16 (buffer boffset data start end) (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) + (type (simple-array int16 (*)) data) + (type array-index boffset start end)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-int16 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-wbuf data + buffer-woffset + (index+ buffer-woffset length) + index) + (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type (simple-array int16 (*)) data) - (type array-index boffset start end)) + (type (simple-array int16 (*)) data) + (type array-index boffset start end)) (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-int16 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defun write-vector-int16 (buffer boffset data start end) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-int16 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) - (buffer-replace buffer-wbuf data - buffer-woffset - (index+ buffer-woffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-wbuf data + buffer-woffset + (index+ buffer-woffset length) + index) + (setq index (index+ index length))))) nil) (defun write-vector-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks int16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-int16 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-int16 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-int16 int16 @@ -1194,93 +1194,93 @@ #-lispm (defun write-simple-array-card32 (buffer boffset data start end) (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) + (type (simple-array card32 (*)) data) + (type array-index boffset start end)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card32 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-lbuf data + buffer-loffset + (index+ buffer-loffset length) + index) + (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type (simple-array card32 (*)) data) - (type array-index boffset start end)) + (type (simple-array card32 (*)) data) + (type array-index boffset start end)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card32 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defun write-vector-card32 (buffer boffset data start end) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (aref data index)) - (setq index (index+ index 1))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card32 j (aref data index)) + (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) - (buffer-replace buffer-lbuf data - buffer-loffset - (index+ buffer-loffset length) - index) - (setq index (index+ index length))))) + (buffer-replace buffer-lbuf data + buffer-loffset + (index+ buffer-loffset length) + index) + (setq index (index+ index length))))) nil) (defun write-vector-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card32 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) - ((index>= j chunk)) - (declare (type array-index j)) - (write-card32 j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j chunk)) + (declare (type array-index j)) + (write-card32 j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card32 card32 @@ -1293,44 +1293,44 @@ (defun read-bitvector256 (buffer-bbuf boffset data) (declare (type buffer-bytes buffer-bbuf) - (type array-index boffset) - (type (or null (simple-bit-vector 256)) data)) + (type array-index boffset) + (type (or null (simple-bit-vector 256)) data)) (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) (declare (type (simple-bit-vector 256) result)) (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) + (j 8 (index+ j 8))) + ((index>= j 256)) (declare (type array-index i j)) (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) - (k j (index+ k 1))) - ((zerop byte) - (when data ;; Clear uninitialized bits in data - (do ((end (index+ j 8))) - ((index= k end)) - (declare (type array-index end)) - (setf (aref result k) 0) - (index-incf k)))) - (declare (type array-index k) - (type card8 byte)) - (setf (aref result k) (the bit (logand byte 1))))) + (k j (index+ k 1))) + ((zerop byte) + (when data ;; Clear uninitialized bits in data + (do ((end (index+ j 8))) + ((index= k end)) + (declare (type array-index end)) + (setf (aref result k) 0) + (index-incf k)))) + (declare (type array-index k) + (type card8 byte)) + (setf (aref result k) (the bit (logand byte 1))))) result)) (defun write-bitvector256 (buffer boffset map) (declare (type buffer buffer) - (type array-index boffset) - (type (simple-array bit (*)) map)) + (type array-index boffset) + (type (simple-array bit (*)) map)) (with-buffer-output (buffer :index boffset :sizes 8) - (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte - (j 8 (index+ j 8))) - ((index>= j 256)) + (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte + (j 8 (index+ j 8))) + ((index>= j 256)) (declare (type array-index i j)) (do ((byte 0) - (bit (index+ j 7) (index- bit 1))) - ((index< bit j) - (aset-card8 byte buffer-bbuf i)) - (declare (type array-index bit) - (type card8 byte)) - (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) + (bit (index+ j 7) (index- bit 1))) + ((index< bit j) + (aset-card8 byte buffer-bbuf i)) + (declare (type array-index bit) + (type card8 byte)) + (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) ;;; Writing sequences of char2b's @@ -1340,75 +1340,75 @@ #-lispm (defun write-simple-array-char2b (buffer boffset data start end) (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) + (type (simple-array card16 (*)) data) + (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) + ((index>= j (1- chunk)) (setf chunk j)) + (declare (type array-index j)) + (write-char2b j (aref data index)) + (setq index (index+ index 1))))) nil) #-lispm (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type (simple-array card16 (*)) data) - (type array-index boffset start end)) + (type (simple-array card16 (*)) data) + (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j (1- chunk)) (setf chunk j)) + (declare (type array-index j)) + (write-char2b j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (defun write-vector-char2b (buffer boffset data start end) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (aref data index)) - (setq index (index+ index 1))))) + ((index>= j (1- chunk)) (setf chunk j)) + (declare (type array-index j)) + (write-char2b j (aref data index)) + (setq index (index+ index 1))))) nil) (defun write-vector-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) - (type vector data) - (type array-index boffset start end) - (optimize #+cmu(ext:inhibit-warnings 3))) + (type vector data) + (type array-index boffset start end) + (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + #+clx-ansi-common-lisp + (dynamic-extent transform) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 - ((index start)) - ((type array-index index)) + ((index start)) + ((type array-index index)) (do ((j 0 (index+ j 2))) - ((index>= j (1- chunk)) (setf chunk j)) - (declare (type array-index j)) - (write-char2b j (funcall transform (aref data index))) - (setq index (index+ index 1))))) + ((index>= j (1- chunk)) (setf chunk j)) + (declare (type array-index j)) + (write-char2b j (funcall transform (aref data index))) + (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-char2b card16 diff --git a/src/clx/bufmac.lisp b/src/clx/bufmac.lisp index 1e002b824..9bc1f8bdd 100644 --- a/src/clx/bufmac.lisp +++ b/src/clx/bufmac.lisp @@ -4,9 +4,9 @@ ;;; X windows version 11 ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -32,51 +32,51 @@ (defmacro write-card16 (byte-index item) #+clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) + (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) + (index+ buffer-boffset ,byte-index))) (defmacro write-int16 (byte-index item) #+clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-wbuf - (index+ buffer-woffset (index-ash ,byte-index -1))) + (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) + (index+ buffer-boffset ,byte-index))) (defmacro write-card32 (byte-index item) #+clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) + (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) + (index+ buffer-boffset ,byte-index))) (defmacro write-int32 (byte-index item) #+clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) + (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) + (index+ buffer-boffset ,byte-index))) (defmacro write-card29 (byte-index item) #+clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-lbuf - (index+ buffer-loffset (index-ash ,byte-index -2))) + (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-bbuf - (index+ buffer-boffset ,byte-index))) + (index+ buffer-boffset ,byte-index))) ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries ;; and always are written high-order byte first. (defmacro write-char2b (byte-index item) ;; It is impossible to do an overlapping write, so only nonoverlapping here. `(let ((%item ,item) - (%byte-index (index+ buffer-boffset ,byte-index))) + (%byte-index (index+ buffer-boffset ,byte-index))) (declare (type card16 %item) - (type array-index %byte-index)) + (type array-index %byte-index)) (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) @@ -87,10 +87,10 @@ (setq buffer-boffset .boffset.) #+clx-overlapping-arrays ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-woffset (index-ash .boffset. -1)))) + `((setq buffer-woffset (index-ash .boffset. -1)))) #+clx-overlapping-arrays ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) - `((setq buffer-loffset (index-ash .boffset. -2)))) + `((setq buffer-loffset (index-ash .boffset. -2)))) #+clx-overlapping-arrays .boffset.)) @@ -103,45 +103,45 @@ (declare (type display %buffer)) ,(declare-bufmac) ,(when length - `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) - (buffer-flush %buffer))) + `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) + (buffer-flush %buffer))) (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) - #-clx-overlapping-arrays - (buffer-bbuf (buffer-obuf8 %buffer)) - #+clx-overlapping-arrays - ,@(append - (when (member 8 sizes) - `((buffer-bbuf (buffer-obuf8 %buffer)))) - (when (or (member 16 sizes) (member 160 sizes)) - `((buffer-woffset (index-ash buffer-boffset -1)) - (buffer-wbuf (buffer-obuf16 %buffer)))) - (when (member 32 sizes) - `((buffer-loffset (index-ash buffer-boffset -2)) - (buffer-lbuf (buffer-obuf32 %buffer)))))) + #-clx-overlapping-arrays + (buffer-bbuf (buffer-obuf8 %buffer)) + #+clx-overlapping-arrays + ,@(append + (when (member 8 sizes) + `((buffer-bbuf (buffer-obuf8 %buffer)))) + (when (or (member 16 sizes) (member 160 sizes)) + `((buffer-woffset (index-ash buffer-boffset -1)) + (buffer-wbuf (buffer-obuf16 %buffer)))) + (when (member 32 sizes) + `((buffer-loffset (index-ash buffer-boffset -2)) + (buffer-lbuf (buffer-obuf32 %buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append - (when (member 8 sizes) - '((declare (type buffer-bytes buffer-bbuf)))) - (when (member 16 sizes) - '((declare (type array-index buffer-woffset)) - (declare (type buffer-words buffer-wbuf)))) - (when (member 32 sizes) - '((declare (type array-index buffer-loffset)) - (declare (type buffer-longs buffer-lbuf))))) + (when (member 8 sizes) + '((declare (type buffer-bytes buffer-bbuf)))) + (when (member 16 sizes) + '((declare (type array-index buffer-woffset)) + (declare (type buffer-words buffer-wbuf)))) + (when (member 32 sizes) + '((declare (type array-index buffer-loffset)) + (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append - (when (member 8 sizes) '(buffer-bbuf)) - (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) - (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) + (when (member 8 sizes) '(buffer-bbuf)) + (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) + (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) - ,@body) + ,@body) #-clx-overlapping-arrays ,@body))) @@ -151,34 +151,34 @@ (when (> (length body) 2) (error "writing-buffer-chunks called with too many forms")) (let* ((size (* 8 (index-increment type))) - (form #-clx-overlapping-arrays - (first body) - #+clx-overlapping-arrays ; XXX type dependencies - (or (second body) - (first body)))) + (form #-clx-overlapping-arrays + (first body) + #+clx-overlapping-arrays ; XXX type dependencies + (or (second body) + (first body)))) `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) ;; Loop filling the buffer (do* (,@args - ;; Number of bytes needed to output - (len ,(if (= size 8) - `(index- end start) - `(index-ash (index- end start) ,(truncate size 16))) - (index- len chunk)) - ;; Number of bytes available in buffer - (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) - (index-min len (index- (buffer-size buffer) buffer-boffset)))) - ((not (index-plusp len))) - (declare ,@decls - (type array-index len chunk)) - ,form - (index-incf buffer-boffset chunk) - ;; Flush the buffer - (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) - (setf (buffer-boffset buffer) buffer-boffset) - (buffer-flush buffer) - (setq buffer-boffset (buffer-boffset buffer)) - #+clx-overlapping-arrays - ,(case size - (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) - (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) + ;; Number of bytes needed to output + (len ,(if (= size 8) + `(index- end start) + `(index-ash (index- end start) ,(truncate size 16))) + (index- len chunk)) + ;; Number of bytes available in buffer + (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) + (index-min len (index- (buffer-size buffer) buffer-boffset)))) + ((not (index-plusp len))) + (declare ,@decls + (type array-index len chunk)) + ,form + (index-incf buffer-boffset chunk) + ;; Flush the buffer + (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) + (setf (buffer-boffset buffer) buffer-boffset) + (buffer-flush buffer) + (setq buffer-boffset (buffer-boffset buffer)) + #+clx-overlapping-arrays + ,(case size + (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) + (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) (setf (buffer-boffset buffer) (lround buffer-boffset))))) diff --git a/src/clx/build-clx.lisp b/src/clx/build-clx.lisp index 76b3299ea..5f4b0a32b 100644 --- a/src/clx/build-clx.lisp +++ b/src/clx/build-clx.lisp @@ -2,7 +2,7 @@ ;;; Load this file if you want to compile CLX in its entirety. (proclaim '(optimize (speed 3) (safety 1) (space 1) - (compilation-speed 0))) + (compilation-speed 0))) ;;; Hide CLOS from CLX, so objects stay implemented as structures. diff --git a/src/clx/clx.lisp b/src/clx/clx.lisp index ce81f6de5..400601e84 100644 --- a/src/clx/clx.lisp +++ b/src/clx/clx.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -17,59 +17,59 @@ ;;; ;; Primary Interface Author: -;; Robert W. Scheifler -;; MIT Laboratory for Computer Science -;; 545 Technology Square, Room 418 -;; Cambridge, MA 02139 -;; rws@zermatt.lcs.mit.edu +;; Robert W. Scheifler +;; MIT Laboratory for Computer Science +;; 545 Technology Square, Room 418 +;; Cambridge, MA 02139 +;; rws@zermatt.lcs.mit.edu ;; Design Contributors: -;; Dan Cerys, Texas Instruments -;; Scott Fahlman, CMU +;; Dan Cerys, Texas Instruments +;; Scott Fahlman, CMU ;; Charles Hornig, Symbolics ;; John Irwin, Franz -;; Kerry Kimbrough, Texas Instruments -;; Chris Lindblad, MIT -;; Rob MacLachlan, CMU -;; Mike McMahon, Symbolics -;; David Moon, Symbolics -;; LaMott Oren, Texas Instruments -;; Daniel Weinreb, Symbolics -;; John Wroclawski, MIT -;; Richard Zippel, Symbolics +;; Kerry Kimbrough, Texas Instruments +;; Chris Lindblad, MIT +;; Rob MacLachlan, CMU +;; Mike McMahon, Symbolics +;; David Moon, Symbolics +;; LaMott Oren, Texas Instruments +;; Daniel Weinreb, Symbolics +;; John Wroclawski, MIT +;; Richard Zippel, Symbolics ;; Primary Implementation Author: -;; LaMott Oren, Texas Instruments +;; LaMott Oren, Texas Instruments ;; Implementation Contributors: ;; Charles Hornig, Symbolics ;; John Irwin, Franz -;; Chris Lindblad, MIT -;; Robert Scheifler, MIT +;; Chris Lindblad, MIT +;; Robert Scheifler, MIT ;;; ;;; Change history: ;;; -;;; Date Author Description +;;; Date Author Description ;;; ------------------------------------------------------------------------------------- -;;; 04/07/87 R.Scheifler Created code stubs -;;; 04/08/87 L.Oren Started Implementation -;;; 05/11/87 L.Oren Included draft 3 revisions -;;; 07/07/87 L.Oren Untested alpha release to MIT -;;; 07/17/87 L.Oren Alpha release -;;; 08/**/87 C.Lindblad Rewrite of buffer code -;;; 08/**/87 et al Various random bug fixes -;;; 08/**/87 R.Scheifler General syntactic and portability cleanups -;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing -;;; 09/02/87 L.Oren Change events from resource-ids to objects -;;; 12/24/87 R.Budzianowski KCL support -;;; 12/**/87 J.Irwin ExCL 2.0 support -;;; 01/20/88 L.Oren Add server extension mechanisms -;;; 01/20/88 L.Oren Only force output when blocking on input -;;; 01/20/88 L.Oren Uniform support for :event-window on events -;;; 01/28/88 L.Oren Add window manager property functions -;;; 01/28/88 L.Oren Add character translation facility -;;; 02/**/87 J.Irwin Allegro 2.2 support +;;; 04/07/87 R.Scheifler Created code stubs +;;; 04/08/87 L.Oren Started Implementation +;;; 05/11/87 L.Oren Included draft 3 revisions +;;; 07/07/87 L.Oren Untested alpha release to MIT +;;; 07/17/87 L.Oren Alpha release +;;; 08/**/87 C.Lindblad Rewrite of buffer code +;;; 08/**/87 et al Various random bug fixes +;;; 08/**/87 R.Scheifler General syntactic and portability cleanups +;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing +;;; 09/02/87 L.Oren Change events from resource-ids to objects +;;; 12/24/87 R.Budzianowski KCL support +;;; 12/**/87 J.Irwin ExCL 2.0 support +;;; 01/20/88 L.Oren Add server extension mechanisms +;;; 01/20/88 L.Oren Only force output when blocking on input +;;; 01/20/88 L.Oren Uniform support for :event-window on events +;;; 01/28/88 L.Oren Add window manager property functions +;;; 01/28/88 L.Oren Add character translation facility +;;; 02/**/87 J.Irwin Allegro 2.2 support ;;; This is considered a somewhat changeable interface. Discussion of better ;;; integration with CLOS, support for user-specified subclassess of basic @@ -120,26 +120,26 @@ ; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with ; ;; cache-p true. ; (declare (type display display) -; (type integer resource-id) -; (clx-values ))) +; (type integer resource-id) +; (clx-values ))) ;(defun -display () ; (declare (type ) -; (clx-values display))) +; (clx-values display))) ;(defun -id () ; (declare (type ) -; (clx-values integer))) +; (clx-values integer))) ;(defun -equal (-1 -2) ; (declare (type -1 -2))) ;(defun -p (-1 -2) ; (declare (type -1 -2) -; (clx-values boolean))) +; (clx-values boolean))) -(deftype generalized-boolean () 't) ; (or null (not null)) +(deftype generalized-boolean () 't) ; (or null (not null)) (deftype card32 () '(unsigned-byte 32)) @@ -162,12 +162,12 @@ #-clx-ansi-common-lisp (deftype real (&optional (min '*) (max '*)) (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0s0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) + (typecase limit + (number (if floatp (float limit 0s0) (rational limit))) + (list (map 'list #'convert limit)) + (otherwise limit)))) `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) + (rational ,(convert min nil) ,(convert max nil))))) #-clx-ansi-common-lisp (deftype base-char () @@ -201,14 +201,14 @@ ; than what is actually transmitted in the protocol. (def-clx-class (color (:constructor make-color-internal (red green blue)) - (:copier nil) (:print-function print-color)) + (:copier nil) (:print-function print-color)) (red 0.0 :type rgb-val) (green 0.0 :type rgb-val) (blue 0.0 :type rgb-val)) (defun print-color (color stream depth) (declare (type color color) - (ignore depth)) + (ignore depth)) (print-unreadable-object (color stream :type t) (prin1 (color-red color) stream) (write-string " " stream) @@ -233,12 +233,12 @@ (defun print-bitmap-format (bitmap-format stream depth) (declare (type bitmap-format bitmap-format) - (ignore depth)) + (ignore depth)) (print-unreadable-object (bitmap-format stream :type t) (format stream "unit ~D pad ~D ~:[M~;L~]SB first" - (bitmap-format-unit bitmap-format) - (bitmap-format-pad bitmap-format) - (bitmap-format-lsb-first-p bitmap-format)))) + (bitmap-format-unit bitmap-format) + (bitmap-format-pad bitmap-format) + (bitmap-format-lsb-first-p bitmap-format)))) (def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format)) (depth 0 :type image-depth) @@ -247,119 +247,119 @@ (defun print-pixmap-format (pixmap-format stream depth) (declare (type pixmap-format pixmap-format) - (ignore depth)) + (ignore depth)) (print-unreadable-object (pixmap-format stream :type t) (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D" - (pixmap-format-depth pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format) - (pixmap-format-scanline-pad pixmap-format)))) + (pixmap-format-depth pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format) + (pixmap-format-scanline-pad pixmap-format)))) (defparameter *atom-cache-size* 200) (defparameter *resource-id-map-size* 500) (def-clx-class (display (:include buffer) - (:constructor make-display-internal) - (:print-function print-display) - (:copier nil)) - (host) ; Server Host - (display 0 :type integer) ; Display number on host - (after-function nil) ; Function to call after every request + (:constructor make-display-internal) + (:print-function print-display) + (:copier nil)) + (host) ; Server Host + (display 0 :type integer) ; Display number on host + (after-function nil) ; Function to call after every request (event-lock - (make-process-lock "CLX Event Lock")) ; with-event-queue lock + (make-process-lock "CLX Event Lock")) ; with-event-queue lock (event-queue-lock - (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock - (event-queue-tail ; last event in the event queue + (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock + (event-queue-tail ; last event in the event queue nil :type (or null reply-buffer)) - (event-queue-head ; Threaded queue of events + (event-queue-head ; Threaded queue of events nil :type (or null reply-buffer)) (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*) - :type hash-table) ; Hash table relating atoms keywords - ; to atom id's - (font-cache nil) ; list of font - (protocol-major-version 0 :type card16) ; Major version of server's X protocol - (protocol-minor-version 0 :type card16) ; minor version of servers X protocol - (vendor-name "" :type string) ; vendor of the server hardware - (resource-id-base 0 :type resource-id) ; resouce ID base - (resource-id-mask 0 :type resource-id) ; resource ID mask bits - (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) - (resource-id-count 0 :type resource-id) ; resource ID mask count - ; (used for allocating ID's) + :type hash-table) ; Hash table relating atoms keywords + ; to atom id's + (font-cache nil) ; list of font + (protocol-major-version 0 :type card16) ; Major version of server's X protocol + (protocol-minor-version 0 :type card16) ; minor version of servers X protocol + (vendor-name "" :type string) ; vendor of the server hardware + (resource-id-base 0 :type resource-id) ; resouce ID base + (resource-id-mask 0 :type resource-id) ; resource ID mask bits + (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) + (resource-id-count 0 :type resource-id) ; resource ID mask count + ; (used for allocating ID's) (resource-id-map (make-hash-table :test (resource-id-map-test) - :size *resource-id-map-size*) - :type hash-table) ; hash table maps resource-id's to - ; objects (used in lookup functions) - (xid 'resourcealloc) ; allocator function + :size *resource-id-map-size*) + :type hash-table) ; hash table maps resource-id's to + ; objects (used in lookup functions) + (xid 'resourcealloc) ; allocator function (byte-order #+clx-little-endian :lsbfirst ; connection byte order - #-clx-little-endian :msbfirst) - (release-number 0 :type card32) ; release of the server - (max-request-length 0 :type card16) ; maximum number 32 bit words in request - (default-screen) ; default screen for operations - (roots nil :type list) ; List of screens - (motion-buffer-size 0 :type card32) ; size of motion buffer - (xdefaults) ; contents of defaults from server + #-clx-little-endian :msbfirst) + (release-number 0 :type card32) ; release of the server + (max-request-length 0 :type card16) ; maximum number 32 bit words in request + (default-screen) ; default screen for operations + (roots nil :type list) ; List of screens + (motion-buffer-size 0 :type card32) ; size of motion buffer + (xdefaults) ; contents of defaults from server (image-lsb-first-p nil :type generalized-boolean) - (bitmap-format (make-bitmap-format) ; Screen image info - :type bitmap-format) - (pixmap-formats nil :type sequence) ; list of pixmap formats - (min-keycode 0 :type card8) ; minimum key-code - (max-keycode 0 :type card8) ; maximum key-code - (error-handler 'default-error-handler) ; Error handler function - (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode + (bitmap-format (make-bitmap-format) ; Screen image info + :type bitmap-format) + (pixmap-formats nil :type sequence) ; list of pixmap formats + (min-keycode 0 :type card8) ; minimum key-code + (max-keycode 0 :type card8) ; maximum key-code + (error-handler 'default-error-handler) ; Error handler function + (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode (authorization-name "" :type string) (authorization-data "" :type (or (array (unsigned-byte 8)) string)) - (last-width nil :type (or null card29)) ; Accumulated width of last string - (keysym-mapping nil ; Keysym mapping cached from server - :type (or null (array * (* *)))) - (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms - (keysym-translation nil :type list) ; An alist of (keysym object function) - ; for display-local keysyms - (extension-alist nil :type list) ; extension alist, which has elements: - ; (name major-opcode first-event first-error) - (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys - (performance-info) ; Hook for gathering performance info - (trace-history) ; Hook for debug trace - (plist nil :type list) ; hook for extension to hang data + (last-width nil :type (or null card29)) ; Accumulated width of last string + (keysym-mapping nil ; Keysym mapping cached from server + :type (or null (array * (* *)))) + (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms + (keysym-translation nil :type list) ; An alist of (keysym object function) + ; for display-local keysyms + (extension-alist nil :type list) ; extension alist, which has elements: + ; (name major-opcode first-event first-error) + (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys + (performance-info) ; Hook for gathering performance info + (trace-history) ; Hook for debug trace + (plist nil :type list) ; hook for extension to hang data ;; These slots are used to manage multi-process input. - (input-in-progress nil) ; Some process reading from the stream. - ; Updated with CONDITIONAL-STORE. - (pending-commands nil) ; Threaded list of PENDING-COMMAND objects - ; for all commands awaiting replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects - ; containing error messages for commands - ; which did not expect replies. - ; Protected by WITH-EVENT-QUEUE-INTERNAL. - (report-asynchronous-errors ; When to report asynchronous errors - '(:immediately) :type list) ; The keywords that can be on this list - ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, - ; and :AFTER-FINISH-OUTPUT - (event-process nil) ; Process ID of process awaiting events. - ; Protected by WITH-EVENT-QUEUE. - (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the - ; event queue. - ; Protected by WITH-EVENT-QUEUE. - (current-event-symbol ; Bound with PROGV by event handling macros + (input-in-progress nil) ; Some process reading from the stream. + ; Updated with CONDITIONAL-STORE. + (pending-commands nil) ; Threaded list of PENDING-COMMAND objects + ; for all commands awaiting replies. + ; Protected by WITH-EVENT-QUEUE-INTERNAL. + (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects + ; containing error messages for commands + ; which did not expect replies. + ; Protected by WITH-EVENT-QUEUE-INTERNAL. + (report-asynchronous-errors ; When to report asynchronous errors + '(:immediately) :type list) ; The keywords that can be on this list + ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, + ; and :AFTER-FINISH-OUTPUT + (event-process nil) ; Process ID of process awaiting events. + ; Protected by WITH-EVENT-QUEUE. + (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the + ; event queue. + ; Protected by WITH-EVENT-QUEUE. + (current-event-symbol ; Bound with PROGV by event handling macros (list (gensym) (gensym)) :type cons) (atom-id-map (make-hash-table :test (resource-id-map-test) - :size *atom-cache-size*) - :type hash-table) + :size *atom-cache-size*) + :type hash-table) (extended-max-request-length 0 :type card32) ) (defun print-display-name (display stream) (declare (type (or null display) display)) (cond (display - #-allegro (princ (display-host display) stream) - #+allegro (write-string (string (display-host display)) stream) - (write-string ":" stream) - (princ (display-display display) stream)) - (t - (write-string "(no display)" stream))) + #-allegro (princ (display-host display) stream) + #+allegro (write-string (string (display-host display)) stream) + (write-string ":" stream) + (princ (display-display display) stream)) + (t + (write-string "(no display)" stream))) display) (defun print-display (display stream depth) (declare (type display display) - (ignore depth)) + (ignore depth)) (print-unreadable-object (display stream :type t) (print-display-name display stream) (write-string " (" stream) @@ -373,41 +373,41 @@ (def-clx-class (drawable (:copier nil) (:print-function print-drawable)) (id 0 :type resource-id) (display nil :type (or null display)) - (plist nil :type list) ; Extension hook + (plist nil :type list) ; Extension hook ) (defun print-drawable (drawable stream depth) (declare (type drawable drawable) - (ignore depth)) + (ignore depth)) (print-unreadable-object (drawable stream :type t) (print-display-name (drawable-display drawable) stream) (write-string " " stream) (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream)))) (def-clx-class (window (:include drawable) (:copier nil) - (:print-function print-drawable)) + (:print-function print-drawable)) ) (def-clx-class (pixmap (:include drawable) (:copier nil) - (:print-function print-drawable)) + (:print-function print-drawable)) ) (def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) (id 0 :type resource-id) (display nil :type (or null display)) (class :static-gray :type (member :static-gray :static-color :true-color - :gray-scale :pseudo-color :direct-color)) + :gray-scale :pseudo-color :direct-color)) (red-mask 0 :type pixel) (green-mask 0 :type pixel) (blue-mask 0 :type pixel) (bits-per-rgb 1 :type card8) (colormap-entries 0 :type card16) - (plist nil :type list) ; Extension hook + (plist nil :type list) ; Extension hook ) (defun print-visual-info (visual-info stream depth) (declare (type visual-info visual-info) - (ignore depth)) + (ignore depth)) (print-unreadable-object (visual-info stream :type t) (prin1 (visual-info-bits-per-rgb visual-info) stream) (write-string "-bit " stream) @@ -425,7 +425,7 @@ (defun print-colormap (colormap stream depth) (declare (type colormap colormap) - (ignore depth)) + (ignore depth)) (print-unreadable-object (colormap stream :type t) (when (colormap-visual-info colormap) (princ (visual-info-class (colormap-visual-info colormap)) stream) @@ -441,7 +441,7 @@ (defun print-cursor (cursor stream depth) (declare (type cursor cursor) - (ignore depth)) + (ignore depth)) (print-unreadable-object (cursor stream :type t) (print-display-name (cursor-display cursor) stream) (write-string " " stream) @@ -489,7 +489,7 @@ (deftype bit-gravity () '(member :forget :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) + :center :east :south-west :south :south-east :static)) (defconstant +win-gravity-vector+ '#(:unmap :north-west :north :north-east :west @@ -510,7 +510,7 @@ (deftype win-gravity () '(member :unmap :north-west :north :north-east :west - :center :east :south-west :south :south-east :static)) + :center :east :south-west :south :south-east :static)) (deftype grab-status () '(member :success :already-grabbed :invalid-time :not-viewable)) @@ -537,7 +537,7 @@ (deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) - (angle angle1) (angle angle2))) + (angle angle1) (angle angle2))) (deftype gcontext-state () 'simple-vector) @@ -549,13 +549,13 @@ (cache-p t :type generalized-boolean) (server-state (allocate-gcontext-state) :type gcontext-state) (local-state (allocate-gcontext-state) :type gcontext-state) - (plist nil :type list) ; Extension hook + (plist nil :type list) ; Extension hook (next nil #-explorer :type #-explorer (or null gcontext)) ) (defun print-gcontext (gcontext stream depth) (declare (type gcontext gcontext) - (ignore depth)) + (ignore depth)) (print-unreadable-object (gcontext stream :type t) (print-display-name (gcontext-display gcontext) stream) (write-string " " stream) @@ -571,11 +571,11 @@ (deftype event-mask-class () '(member :key-press :key-release :owner-grab-button :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :exposure :visibility-change - :structure-notify :resize-redirect :substructure-notify :substructure-redirect - :focus-change :property-change :colormap-change :keymap-state)) + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :exposure :visibility-change + :structure-notify :resize-redirect :substructure-notify :substructure-redirect + :focus-change :property-change :colormap-change :keymap-state)) (deftype event-mask () '(or mask32 (clx-list event-mask-class))) @@ -591,9 +591,9 @@ (deftype pointer-event-mask-class () '(member :button-press :button-release - :enter-window :leave-window :pointer-motion :pointer-motion-hint - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion :keymap-state)) + :enter-window :leave-window :pointer-motion :pointer-motion-hint + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion :keymap-state)) (deftype pointer-event-mask () '(or mask32 (clx-list pointer-event-mask-class))) @@ -605,8 +605,8 @@ (deftype device-event-mask-class () '(member :key-press :key-release :button-press :button-release :pointer-motion - :button-1-motion :button-2-motion :button-3-motion :button-4-motion - :button-5-motion :button-motion)) + :button-1-motion :button-2-motion :button-3-motion :button-4-motion + :button-5-motion :button-motion)) (deftype device-event-mask () '(or mask32 (clx-list device-event-mask-class))) @@ -633,10 +633,10 @@ (deftype gcontext-key () '(member :function :plane-mask :foreground :background - :line-width :line-style :cap-style :join-style :fill-style - :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode - :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes - :arc-mode)) + :line-width :line-style :cap-style :join-style :fill-style + :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode + :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes + :arc-mode)) (deftype event-key () '(or (member :key-press :key-release :button-press :button-release @@ -652,7 +652,7 @@ (deftype error-key () '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice - :illegal-request :implementation :length :match :name :pixmap :value :window)) + :illegal-request :implementation :length :match :name :pixmap :value :window)) (deftype draw-direction () '(member :left-to-right :right-to-left)) @@ -665,9 +665,9 @@ (deftype boole-constant () `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 - ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior - ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 - ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) + ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior + ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 + ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) (def-clx-class (screen (:copier nil) (:print-function print-screen)) (root nil :type (or null window)) @@ -686,12 +686,12 @@ (backing-stores :never :type (member :never :when-mapped :always)) (save-unders-p nil :type generalized-boolean) (event-mask-at-open 0 :type mask32) - (plist nil :type list) ; Extension hook + (plist nil :type list) ; Extension hook ) (defun print-screen (screen stream depth) (declare (type screen screen) - (ignore depth)) + (ignore depth)) (print-unreadable-object (screen stream :type t) (let ((display (drawable-display (screen-root screen)))) (print-display-name display stream) @@ -709,7 +709,7 @@ (defun screen-root-visual (screen) (declare (type screen screen) - (clx-values resource-id)) + (clx-values resource-id)) (visual-info-id (screen-root-visual-info screen))) ;; The list contains alternating keywords and integers. @@ -732,7 +732,7 @@ (properties nil :type font-props)) (def-clx-class (font (:constructor make-font-internal) (:copier nil) - (:print-function print-font)) + (:print-function print-font)) (id-internal nil :type (or null resource-id)) ;; NIL when not opened (display nil :type (or null display)) (reference-count 0 :type fixnum) @@ -740,15 +740,15 @@ (font-info-internal nil :type (or null font-info)) (char-infos-internal nil :type (or null (simple-array int16 (*)))) (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally - (plist nil :type list) ; Extension hook + (plist nil :type list) ; Extension hook ) (defun print-font (font stream depth) (declare (type font font) - (ignore depth)) + (ignore depth)) (print-unreadable-object (font stream :type t) (if (font-name font) - (princ (font-name font) stream) + (princ (font-name font) stream) (write-string "(gcontext)" stream)) (write-string " " stream) (print-display-name (font-display font) stream) @@ -768,41 +768,41 @@ (defun font-char-infos (font) (or (font-char-infos-internal font) (progn (query-font font) - (font-char-infos-internal font)))) + (font-char-infos-internal font)))) (defun make-font (&key id - display - (reference-count 0) - (name "") - (local-only-p t) - font-info-internal) + display + (reference-count 0) + (name "") + (local-only-p t) + font-info-internal) (make-font-internal :id-internal id - :display display - :reference-count reference-count - :name name - :local-only-p local-only-p - :font-info-internal font-info-internal)) + :display display + :reference-count reference-count + :name name + :local-only-p local-only-p + :font-info-internal font-info-internal)) ; For each component ( :type ) of font-info, ; there is a corresponding function: ;(defun font- (font) ; (declare (type font font) -; (clx-values ))) +; (clx-values ))) (macrolet ((make-font-info-accessors (useless-name &body fields) - `(within-definition (,useless-name make-font-info-accessors) - ,@(mapcar - #'(lambda (field) - (let* ((type (second field)) - (n (string (first field))) - (name (xintern 'font- n)) - (accessor (xintern 'font-info- n))) - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values ,type)) - (,accessor (font-font-info font))))) - fields)))) + `(within-definition (,useless-name make-font-info-accessors) + ,@(mapcar + #'(lambda (field) + (let* ((type (second field)) + (n (string (first field))) + (name (xintern 'font- n)) + (accessor (xintern 'font-info- n))) + `(defun ,name (font) + (declare (type font font)) + (declare (clx-values ,type)) + (,accessor (font-font-info font))))) + fields)))) (make-font-info-accessors ignore (direction draw-direction) (min-char card16) @@ -821,23 +821,23 @@ (defun font-property (font name) (declare (type font font) - (type keyword name)) + (type keyword name)) (declare (clx-values (or null int32))) (getf (font-properties font) name)) (macrolet ((make-mumble-equal (type) - ;; Since caching is only done for objects created by the - ;; client, we must always compare ID and display for - ;; non-identical mumbles. - (let ((predicate (xintern type '-equal)) - (id (xintern type '-id)) - (dpy (xintern type '-display))) - `(within-definition (,type make-mumble-equal) - (defun ,predicate (a b) - (declare (type ,type a b)) - (or (eql a b) - (and (= (,id a) (,id b)) - (eq (,dpy a) (,dpy b))))))))) + ;; Since caching is only done for objects created by the + ;; client, we must always compare ID and display for + ;; non-identical mumbles. + (let ((predicate (xintern type '-equal)) + (id (xintern type '-id)) + (dpy (xintern type '-display))) + `(within-definition (,type make-mumble-equal) + (defun ,predicate (a b) + (declare (type ,type a b)) + (or (eql a b) + (and (= (,id a) (,id b)) + (eq (,dpy a) (,dpy b))))))))) (make-mumble-equal window) (make-mumble-equal pixmap) (make-mumble-equal cursor) @@ -856,20 +856,20 @@ ;; in the resulting mask. KEY-LIST is either a mask or a list of ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask. (declare (type (simple-array keyword (*)) key-vector) - (type (or mask32 list) key-list)) + (type (or mask32 list) key-list)) (declare (clx-values (or mask32 null))) (typecase key-list (mask32 key-list) (list (let ((mask 0)) - (dolist (key key-list mask) - (let ((bit (position key (the vector key-vector) :test #'eq))) - (unless bit - (x-type-error key key-type)) - (setq mask (logior mask (ash 1 bit))))))))) + (dolist (key key-list mask) + (let ((bit (position key (the vector key-vector) :test #'eq))) + (unless bit + (x-type-error key key-type)) + (setq mask (logior mask (ash 1 bit))))))))) (defun decode-mask (key-vector mask) (declare (type (simple-array keyword (*)) key-vector) - (type mask32 mask)) + (type mask32 mask)) (declare (clx-values list)) (do ((m mask (ash m -1)) (bit 0 (1+ bit)) @@ -877,8 +877,8 @@ (result nil)) ((or (zerop m) (>= bit len)) result) (declare (type mask32 m) - (fixnum bit len) - (list result)) + (fixnum bit len) + (list result)) (when (oddp m) (push (aref key-vector bit) result)))) @@ -905,7 +905,7 @@ (declare (type device-event-mask device-event-mask)) (declare (clx-values mask32)) (or (encode-mask +device-event-mask-vector+ device-event-mask - 'device-event-mask-class) + 'device-event-mask-class) (x-type-error device-event-mask 'device-event-mask))) (defun encode-modifier-mask (modifier-mask) @@ -936,5 +936,5 @@ (declare (type pointer-event-mask pointer-event-mask)) (declare (clx-values mask32)) (or (encode-mask +pointer-event-mask-vector+ pointer-event-mask - 'pointer-event-mask-class) + 'pointer-event-mask-class) (x-type-error pointer-event-mask 'pointer-event-mask))) diff --git a/src/clx/cmudep.lisp b/src/clx/cmudep.lisp index 8624a3ee3..572fdaa55 100644 --- a/src/clx/cmudep.lisp +++ b/src/clx/cmudep.lisp @@ -14,6 +14,6 @@ (in-package "XLIB") (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) - c-call:int + c-call:int (host c-call:c-string) (port c-call:int)) diff --git a/src/clx/debug/debug.lisp b/src/clx/debug/debug.lisp index 69f3dd636..35e94d19f 100644 --- a/src/clx/debug/debug.lisp +++ b/src/clx/debug/debug.lisp @@ -3,9 +3,9 @@ ;;; CLX debugging code ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -23,11 +23,11 @@ (in-package :xlib) (export '(display-listen - readflush - check-buffer - check-finish - check-force - clear-next)) + readflush + check-buffer + check-finish + check-force + clear-next)) (defun display-listen (display) (listen (display-input-stream display))) @@ -44,23 +44,23 @@ ;; Ensure the output buffer in display is correct (with-buffer-output (display :length :none :sizes (8 16)) (do* ((i 0 (+ i length)) - request - length) - ((>= i buffer-boffset) - (unless (= i buffer-boffset) - (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) + request + length) + ((>= i buffer-boffset) + (unless (= i buffer-boffset) + (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) (let ((buffer-boffset 0) - #+clx-overlapping-arrays - (buffer-woffset 0)) - (setq request (card8-get i)) - (setq length (* 4 (card16-get (+ i 2))))) + #+clx-overlapping-arrays + (buffer-woffset 0)) + (setq request (card8-get i)) + (setq length (* 4 (card16-get (+ i 2))))) (when (zerop request) - (warn "Zero request in buffer") - (return nil)) + (warn "Zero request in buffer") + (return nil)) (when (zerop length) - (warn "Zero length in buffer") - (return nil))))) + (warn "Zero length in buffer") + (return nil))))) (defun check-finish (display) (check-buffer display) diff --git a/src/clx/debug/describe.lisp b/src/clx/debug/describe.lisp index 00371fc95..1f29bfe9e 100644 --- a/src/clx/debug/describe.lisp +++ b/src/clx/debug/describe.lisp @@ -3,9 +3,9 @@ ;;; Describe X11 protocol requests ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -29,1215 +29,1215 @@ (format t "~%Field length not a multiple of 3 for ~a" name)) (let ((request (position name *request-names* :test #'string-equal))) (if request - `(setf (aref *request-parameters* ,request) ',fields) + `(setf (aref *request-parameters* ,request) ',fields) `(format t "~%~s isn't an X11 request name" ',name)))) (defun print-history-description (buffer &optional (start 0)) ;; Display an output history (reading-event (buffer) (let ((request (card8-get start)) - (length (* 4 (card16-get (+ start 2)))) - (margin 5)) + (length (* 4 (card16-get (+ start 2)))) + (margin 5)) (format t "~a (~d) length ~d" - (request-name request) request length) + (request-name request) request length) (when (>= request (length *request-parameters*)) - (setq request 0)) + (setq request 0)) (do ((parms (aref *request-parameters* request) (cdddr parms)) - (j start)) - ((or (endp parms) (>= j length))) - (let ((len (first parms)) - (type (second parms)) - (doc (third parms)) - value) - (setq value (case len - (1 (card8-get j)) - (2 (card16-get j)) - (4 (card32-get j)))) - (format t "~%~v@t" margin) - (if value - (progn - (print-value j value type doc) - (incf j len)) - (progn - (format t "~2d ~10a ~a" - j type doc) - (case type - ((listofvalue listofcard32 listofatom) - (format t " Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 4)) - (format t " ~d" (card32-get j)) - (incf j 4))) - (listofrectangle - (format t " Half-Words:~%~v@t" margin) - (dotimes (k (floor (- length (- j start)) 2)) - (format t " ~d" (card16-get j)) - (incf j 2))) - (x (when (integerp len) (incf j len))) ; Unused - (string8 - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t "~a" (int-char (card8-get j))) - (incf j))) - (otherwise - (format t " Bytes:~%~v@t" margin) - (dotimes (k (- length (- j start))) - (format t " ~d" (card8-get j)) - (incf j))))))))))) + (j start)) + ((or (endp parms) (>= j length))) + (let ((len (first parms)) + (type (second parms)) + (doc (third parms)) + value) + (setq value (case len + (1 (card8-get j)) + (2 (card16-get j)) + (4 (card32-get j)))) + (format t "~%~v@t" margin) + (if value + (progn + (print-value j value type doc) + (incf j len)) + (progn + (format t "~2d ~10a ~a" + j type doc) + (case type + ((listofvalue listofcard32 listofatom) + (format t " Words:~%~v@t" margin) + (dotimes (k (floor (- length (- j start)) 4)) + (format t " ~d" (card32-get j)) + (incf j 4))) + (listofrectangle + (format t " Half-Words:~%~v@t" margin) + (dotimes (k (floor (- length (- j start)) 2)) + (format t " ~d" (card16-get j)) + (incf j 2))) + (x (when (integerp len) (incf j len))) ; Unused + (string8 + (format t " Bytes:~%~v@t" margin) + (dotimes (k (- length (- j start))) + (format t "~a" (int-char (card8-get j))) + (incf j))) + (otherwise + (format t " Bytes:~%~v@t" margin) + (dotimes (k (- length (- j start))) + (format t " ~d" (card8-get j)) + (incf j))))))))))) (defun print-value (i value type doc &aux temp) (format t "~2d ~3d " i value) (if (consp type) (case (first type) - (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) - (setq type (car type))) - (member (if (null (setq temp (nth value (cdr type)))) - (format t "*****ERROR*****") - (format t "~a" temp)) - (setq type (car type)))) + (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) + (setq type (car type))) + (member (if (null (setq temp (nth value (cdr type)))) + (format t "*****ERROR*****") + (format t "~a" temp)) + (setq type (car type)))) (case type ((window pixmap drawable cursor font gcontext colormap atom) (format t "[#x~x]" value) #+comment (let ((temp (lookup-resource-id display value))) - (when (eq (first type) 'atom) - (setq temp (lookup-xatom display value))) - (when temp (format t " (~s)" (type-of temp))))) + (when (eq (first type) 'atom) + (setq temp (lookup-xatom display value))) + (when temp (format t " (~s)" (type-of temp))))) (int16 (setq temp (card16->int16 value)) - (when (minusp temp) (format t "~d" temp))) + (when (minusp temp) (format t "~d" temp))) (otherwise (when (and (numberp type) (not (= type value))) - (format t "*****ERROR*****"))))) + (format t "*****ERROR*****"))))) (format t "~30,10t ~10a ~a" type doc)) (x-request Error - 1 1 opcode - 1 CARD8 data - 2 8+n request-length - n LISTofBYTE data + 1 1 opcode + 1 CARD8 data + 2 8+n request-length + n LISTofBYTE data ) (x-request CreateWindow - 1 1 opcode - 1 CARD8 depth - 2 8+n request-length - 4 WINDOW wid - 4 WINDOW parent - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 2 CARD16 border-width - 2 (MEMBER CopyFromParent InputOutput InputOnly) class - 4 (OR (MEMBER CopyFromParent) VISUALID) visual - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list + 1 1 opcode + 1 CARD8 depth + 2 8+n request-length + 4 WINDOW wid + 4 WINDOW parent + 2 INT16 x + 2 INT16 y + 2 CARD16 width + 2 CARD16 height + 2 CARD16 border-width + 2 (MEMBER CopyFromParent InputOutput InputOnly) class + 4 (OR (MEMBER CopyFromParent) VISUALID) visual + 4 (BITMASK *create-bitmask*) value-mask + 4n LISTofVALUE value-list ) (defparameter *create-bitmask* - #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity - win-gravity backing-store backing-planes backing-pixel override-redirect - save-under event-mask do-not-propagate-mask colormap cursor)) + #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity + win-gravity backing-store backing-planes backing-pixel override-redirect + save-under event-mask do-not-propagate-mask colormap cursor)) (x-request ChangeWindowAttributes - 1 2 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 4 (BITMASK *create-bitmask*) value-mask - 4n LISTofVALUE value-list + 1 2 opcode + 1 x unused + 2 3+n request-length + 4 WINDOW window + 4 (BITMASK *create-bitmask*) value-mask + 4n LISTofVALUE value-list ) (x-request GetWindowAttributes - 1 3 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 3 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request DestroyWindow - 1 4 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 4 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request DestroySubwindows - 1 5 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 5 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request ChangeSaveSet - 1 6 opcode - 1 (MEMBER insert delete) mode - 2 2 request-length - 4 WINDOW window + 1 6 opcode + 1 (MEMBER insert delete) mode + 2 2 request-length + 4 WINDOW window ) (x-request ReparentWindow - 1 7 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 WINDOW parent - 2 INT16 x - 2 INT16 y + 1 7 opcode + 1 x unused + 2 4 request-length + 4 WINDOW window + 4 WINDOW parent + 2 INT16 x + 2 INT16 y ) (x-request MapWindow - 1 8 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 8 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request MapSubwindows - 1 9 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 9 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request UnmapWindow - 1 10 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 10 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request UnmapSubwindows - 1 11 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 11 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request ConfigureWindow - 1 12 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 BITMASK value-mask - 2 x unused - 4n LISTofVALUE value-list + 1 12 opcode + 1 x unused + 2 3+n request-length + 4 WINDOW window + 2 BITMASK value-mask + 2 x unused + 4n LISTofVALUE value-list ) (x-request CirculateWindow - 1 13 opcode - 1 (MEMBER RaiseLowest LowerHighest) direction - 2 2 request-length - 4 WINDOW window + 1 13 opcode + 1 (MEMBER RaiseLowest LowerHighest) direction + 2 2 request-length + 4 WINDOW window ) (x-request GetGeometry - 1 14 opcode - 1 x unused - 2 2 request-length - 4 DRAWABLE drawable + 1 14 opcode + 1 x unused + 2 2 request-length + 4 DRAWABLE drawable ) (x-request QueryTree - 1 15 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 15 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request InternAtom - 1 16 opcode - 1 BOOL only-if-exists - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 16 opcode + 1 BOOL only-if-exists + 2 |2+(n+p)/4| request-length + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request GetAtomName - 1 17 opcode - 1 x unused - 2 2 request-length - 4 ATOM atom + 1 17 opcode + 1 x unused + 2 2 request-length + 4 ATOM atom ) (x-request ChangeProperty - 1 18 opcode - 1 (MEMBER replace prepend append) mode - 2 |6+(n+p)/4| request-length - 4 WINDOW window - 4 ATOM property - 4 ATOM type - 1 CARD8 format - 3 x unused - 4 CARD32 length-of-data-in-format-units - n LISTofBYTE data - p x unused + 1 18 opcode + 1 (MEMBER replace prepend append) mode + 2 |6+(n+p)/4| request-length + 4 WINDOW window + 4 ATOM property + 4 ATOM type + 1 CARD8 format + 3 x unused + 4 CARD32 length-of-data-in-format-units + n LISTofBYTE data + p x unused ) (x-request DeleteProperty - 1 19 opcode - 1 x unused - 2 3 request-length - 4 WINDOW window - 4 ATOM property + 1 19 opcode + 1 x unused + 2 3 request-length + 4 WINDOW window + 4 ATOM property ) (x-request GetProperty - 1 20 opcode - 1 BOOL delete - 2 6 request-length - 4 WINDOW window - 4 ATOM property - 4 (OR (MEMBER anypropertytype) ATOM) type - 4 CARD32 long-offset - 4 CARD32 long-length + 1 20 opcode + 1 BOOL delete + 2 6 request-length + 4 WINDOW window + 4 ATOM property + 4 (OR (MEMBER anypropertytype) ATOM) type + 4 CARD32 long-offset + 4 CARD32 long-length ) (x-request ListProperties - 1 21 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 21 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request SetSelectionOwner - 1 22 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) WINDOW) owner - 4 ATOM selection - 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 22 opcode + 1 x unused + 2 4 request-length + 4 (OR (MEMBER none) WINDOW) owner + 4 ATOM selection + 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GetSelectionOwner - 1 23 opcode - 1 x unused - 2 2 request-length - 4 ATOM selection + 1 23 opcode + 1 x unused + 2 2 request-length + 4 ATOM selection ) (x-request ConvertSelection - 1 24 opcode - 1 x unused - 2 6 request-length - 4 WINDOW requestor - 4 ATOM selection - 4 ATOM target - 4 (OR (MEMBER none) ATOM) property - 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 24 opcode + 1 x unused + 2 6 request-length + 4 WINDOW requestor + 4 ATOM selection + 4 ATOM target + 4 (OR (MEMBER none) ATOM) property + 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request SendEvent - 1 25 opcode - 1 BOOL propagate - 2 11 request-length - 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination - 4 SETofEVENT event-mask - 32 n event + 1 25 opcode + 1 BOOL propagate + 2 11 request-length + 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination + 4 SETofEVENT event-mask + 32 n event ) (x-request GrabPointer - 1 26 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp + 1 26 opcode + 1 BOOL owner-events + 2 6 request-length + 4 WINDOW grab-window + 2 SETofPOINTEREVENT event-mask + 1 (MEMBER Synchronous Asynchronous) pointer-mode + 1 (MEMBER Synchronous Asynchronous) keyboard-mode + 4 (OR (MEMBER none) WINDOW) confine-to + 4 (OR (MEMBER none) CURSOR) cursor + 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp ) (x-request UngrabPointer - 1 27 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 27 opcode + 1 x unused + 2 2 request-length + 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabButton - 1 28 opcode - 1 BOOL owner-events - 2 6 request-length - 4 WINDOW grab-window - 2 SETofPOINTEREVENT event-mask - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 4 (OR (MEMBER none) WINDOW) confine-to - 4 (OR (MEMBER none) CURSOR) cursor - 1 (OR (MEMBER anybutton) BUTTON)button - 1 x unused - 2 SETofKEYMASK modifiers + 1 28 opcode + 1 BOOL owner-events + 2 6 request-length + 4 WINDOW grab-window + 2 SETofPOINTEREVENT event-mask + 1 (MEMBER Synchronous Asynchronous) pointer-mode + 1 (MEMBER Synchronous Asynchronous) keyboard-mode + 4 (OR (MEMBER none) WINDOW) confine-to + 4 (OR (MEMBER none) CURSOR) cursor + 1 (OR (MEMBER anybutton) BUTTON)button + 1 x unused + 2 SETofKEYMASK modifiers ) (x-request UngrabButton - 1 29 opcode - 1 (OR (MEMBER anybutton) BUTTON) button - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused + 1 29 opcode + 1 (OR (MEMBER anybutton) BUTTON) button + 2 3 request-length + 4 WINDOW grab-window + 2 SETofKEYMASK modifiers + 2 x unused ) (x-request ChangeActivePointerGrab - 1 30 opcode - 1 x unused - 2 4 request-length - 4 (OR (MEMBER none) CURSOR) cursor - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 2 SETofPOINTEREVENT event-mask - 2 x unused + 1 30 opcode + 1 x unused + 2 4 request-length + 4 (OR (MEMBER none) CURSOR) cursor + 4 (OR (MEMBER currenttime) TIMESTAMP) time + 2 SETofPOINTEREVENT event-mask + 2 x unused ) (x-request GrabKeyboard - 1 31 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 4 (OR (MEMBER currenttime) TIMESTAMP) time - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 2 x unused + 1 31 opcode + 1 BOOL owner-events + 2 4 request-length + 4 WINDOW grab-window + 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 (MEMBER Synchronous Asynchronous) pointer-mode + 1 (MEMBER Synchronous Asynchronous) keyboard-mode + 2 x unused ) (x-request UngrabKeyboard - 1 32 opcode - 1 x unused - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 32 opcode + 1 x unused + 2 2 request-length + 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabKey - 1 33 opcode - 1 BOOL owner-events - 2 4 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 1 (OR (MEMBER anykey) KEYCODE) key - 1 (MEMBER Synchronous Asynchronous) pointer-mode - 1 (MEMBER Synchronous Asynchronous) keyboard-mode - 3 x unused + 1 33 opcode + 1 BOOL owner-events + 2 4 request-length + 4 WINDOW grab-window + 2 SETofKEYMASK modifiers + 1 (OR (MEMBER anykey) KEYCODE) key + 1 (MEMBER Synchronous Asynchronous) pointer-mode + 1 (MEMBER Synchronous Asynchronous) keyboard-mode + 3 x unused ) (x-request UngrabKey - 1 34 opcode - 1 (OR (MEMBER anykey) KEYCODE) key - 2 3 request-length - 4 WINDOW grab-window - 2 SETofKEYMASK modifiers - 2 x unused + 1 34 opcode + 1 (OR (MEMBER anykey) KEYCODE) key + 2 3 request-length + 4 WINDOW grab-window + 2 SETofKEYMASK modifiers + 2 x unused ) (x-request AllowEvents - 1 35 opcode - 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode - 2 2 request-length - 4 (OR (MEMBER currenttime) TIMESTAMP) time + 1 35 opcode + 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode + 2 2 request-length + 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabServer - 1 36 opcode - 1 x unused - 2 1 request-length + 1 36 opcode + 1 x unused + 2 1 request-length ) (x-request UngrabServer - 1 37 opcode - 1 x unused - 2 1 request-length + 1 37 opcode + 1 x unused + 2 1 request-length ) (x-request QueryPointer - 1 38 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 38 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request GetMotionEvents - 1 39 opcode - 1 x unused - 2 4 request-length - 4 WINDOW window - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop + 1 39 opcode + 1 x unused + 2 4 request-length + 4 WINDOW window + 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start + 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop ) (x-request TranslateCoords - 1 40 opcode - 1 x unused - 2 4 request-length - 4 WINDOW src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y + 1 40 opcode + 1 x unused + 2 4 request-length + 4 WINDOW src-window + 4 WINDOW dst-window + 2 INT16 src-x + 2 INT16 src-y ) (x-request WarpPointer - 1 41 opcode - 1 x unused - 2 6 request-length - 4 (OR (MEMBER none) WINDOW) src-window - 4 WINDOW dst-window - 2 INT16 src-x - 2 INT16 src-y - 2 CARD16 src-width - 2 CARD16 src-height - 2 INT16 dst-x - 2 INT16 dst-y + 1 41 opcode + 1 x unused + 2 6 request-length + 4 (OR (MEMBER none) WINDOW) src-window + 4 WINDOW dst-window + 2 INT16 src-x + 2 INT16 src-y + 2 CARD16 src-width + 2 CARD16 src-height + 2 INT16 dst-x + 2 INT16 dst-y ) (x-request SetInputFocus - 1 42 opcode - 1 (MEMBER none pointerroot parent) revert-to - 2 3 request-length - 4 (OR (MEMBER none pointerroot) WINDOW) focus - 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time + 1 42 opcode + 1 (MEMBER none pointerroot parent) revert-to + 2 3 request-length + 4 (OR (MEMBER none pointerroot) WINDOW) focus + 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time ) (x-request GetInputFocus - 1 43 opcode - 1 x unused - 2 1 request-length + 1 43 opcode + 1 x unused + 2 1 request-length ) (x-request QueryKeymap - 1 44 opcode - 1 x unused - 2 1 request-length + 1 44 opcode + 1 x unused + 2 1 request-length ) (x-request OpenFont - 1 45 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 FONT fid - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 45 opcode + 1 x unused + 2 |3+(n+p)/4| request-length + 4 FONT fid + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request CloseFont - 1 46 opcode - 1 x unused - 2 2 request-length - 4 FONT font + 1 46 opcode + 1 x unused + 2 2 request-length + 4 FONT font ) (x-request QueryFont - 1 47 opcode - 1 x unused - 2 2 request-length - 4 FONTABLE font + 1 47 opcode + 1 x unused + 2 2 request-length + 4 FONTABLE font ) (x-request QueryTextExtents - 1 48 opcode - 1 BOOL odd-length-p - 2 |2+(2n+p)/4| request-length - 4 FONTABLE font - 2n STRING16 string - p x unused + 1 48 opcode + 1 BOOL odd-length-p + 2 |2+(2n+p)/4| request-length + 4 FONTABLE font + 2n STRING16 string + p x unused ) (x-request ListFonts - 1 49 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused + 1 49 opcode + 1 x unused + 2 |2+(n+p)/4| request-length + 2 CARD16 max-names + 2 n length-of-pattern + n STRING8 pattern + p x unused ) (x-request ListFontsWithInfo - 1 50 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 max-names - 2 n length-of-pattern - n STRING8 pattern - p x unused + 1 50 opcode + 1 x unused + 2 |2+(n+p)/4| request-length + 2 CARD16 max-names + 2 n length-of-pattern + n STRING8 pattern + p x unused ) (x-request SetFontPath - 1 51 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 CARD16 number-of-STRs-in-path - 2 x unused - n LISTofSTR path - p x unused + 1 51 opcode + 1 x unused + 2 |2+(n+p)/4| request-length + 2 CARD16 number-of-STRs-in-path + 2 x unused + n LISTofSTR path + p x unused ) (x-request GetFontPath - 1 52 opcode - 1 x unused - 2 1 request-list + 1 52 opcode + 1 x unused + 2 1 request-list ) (x-request CreatePixmap - 1 53 opcode - 1 CARD8 depth - 2 4 request-length - 4 PIXMAP pid - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height + 1 53 opcode + 1 CARD8 depth + 2 4 request-length + 4 PIXMAP pid + 4 DRAWABLE drawable + 2 CARD16 width + 2 CARD16 height ) (x-request FreePixmap - 1 54 opcode - 1 x unused - 2 2 request-length - 4 PIXMAP pixmap + 1 54 opcode + 1 x unused + 2 2 request-length + 4 PIXMAP pixmap ) (x-request CreateGC - 1 55 opcode - 1 x unused - 2 4+n request-length - 4 GCONTEXT cid - 4 DRAWABLE drawable - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list + 1 55 opcode + 1 x unused + 2 4+n request-length + 4 GCONTEXT cid + 4 DRAWABLE drawable + 4 (BITMASK *gc-bitmask*) value-mask + 4n LISTofVALUE value-list ) (defconstant *gc-bitmask* - #(function plane-mask foreground - background line-width line-style cap-style join-style - fill-style fill-rule tile stipple tile-stipple-x-origin - tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin - clip-y-origin clip-mask dash-offset dashes arc-mode)) + #(function plane-mask foreground + background line-width line-style cap-style join-style + fill-style fill-rule tile stipple tile-stipple-x-origin + tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin + clip-y-origin clip-mask dash-offset dashes arc-mode)) (x-request ChangeGC - 1 56 opcode - 1 x unused - 2 3+n request-length - 4 GCONTEXT gc - 4 (BITMASK *gc-bitmask*) value-mask - 4n LISTofVALUE value-list + 1 56 opcode + 1 x unused + 2 3+n request-length + 4 GCONTEXT gc + 4 (BITMASK *gc-bitmask*) value-mask + 4n LISTofVALUE value-list ) (x-request CopyGC - 1 57 opcode - 1 x unused - 2 4 request-length - 4 GCONTEXT src-gc - 4 GCONTEXT dst-gc - 4 (BITMASK *gc-bitmask*) value-mask + 1 57 opcode + 1 x unused + 2 4 request-length + 4 GCONTEXT src-gc + 4 GCONTEXT dst-gc + 4 (BITMASK *gc-bitmask*) value-mask ) (x-request SetDashes - 1 58 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 GCONTEXT gc - 2 CARD16 dash-offset - 2 n length-of-dashes - n LISTofCARD8 dashes - p x unused + 1 58 opcode + 1 x unused + 2 |3+(n+p)/4| request-length + 4 GCONTEXT gc + 2 CARD16 dash-offset + 2 n length-of-dashes + n LISTofCARD8 dashes + p x unused ) (x-request SetClipRectangles - 1 59 opcode - 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering - 2 3+2n request-length - 4 GCONTEXT gc - 2 INT16 clip-x-origin - 2 INT16 clip-y-origin - 8n LISTofRECTANGLE rectangles + 1 59 opcode + 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering + 2 3+2n request-length + 4 GCONTEXT gc + 2 INT16 clip-x-origin + 2 INT16 clip-y-origin + 8n LISTofRECTANGLE rectangles ) (x-request FreeGC - 1 60 opcode - 1 x unused - 2 2 request-length - 4 GCONTEXT gc + 1 60 opcode + 1 x unused + 2 2 request-length + 4 GCONTEXT gc ) (x-request ClearToBackground - 1 61 opcode - 1 BOOL exposures - 2 4 request-length - 4 WINDOW window - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height + 1 61 opcode + 1 BOOL exposures + 2 4 request-length + 4 WINDOW window + 2 INT16 x + 2 INT16 y + 2 CARD16 width + 2 CARD16 height ) (x-request CopyArea - 1 62 opcode - 1 x unused - 2 7 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height + 1 62 opcode + 1 x unused + 2 7 request-length + 4 DRAWABLE src-drawable + 4 DRAWABLE dst-drawable + 4 GCONTEXT gc + 2 INT16 src-x + 2 INT16 src-y + 2 INT16 dst-x + 2 INT16 dst-y + 2 CARD16 width + 2 CARD16 height ) (x-request CopyPlane - 1 63 opcode - 1 x unused - 2 8 request-length - 4 DRAWABLE src-drawable - 4 DRAWABLE dst-drawable - 4 GCONTEXT gc - 2 INT16 src-x - 2 INT16 src-y - 2 INT16 dst-x - 2 INT16 dst-y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 bit-plane + 1 63 opcode + 1 x unused + 2 8 request-length + 4 DRAWABLE src-drawable + 4 DRAWABLE dst-drawable + 4 GCONTEXT gc + 2 INT16 src-x + 2 INT16 src-y + 2 INT16 dst-x + 2 INT16 dst-y + 2 CARD16 width + 2 CARD16 height + 4 CARD32 bit-plane ) (x-request PolyPoint - 1 64 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points + 1 64 opcode + 1 (MEMBER origin previous) coordinate-mode + 2 3+n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 4n LISTofPOINT points ) (x-request PolyLine - 1 65 opcode - 1 (MEMBER origin previous) coordinate-mode - 2 3+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 4n LISTofPOINT points + 1 65 opcode + 1 (MEMBER origin previous) coordinate-mode + 2 3+n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 4n LISTofPOINT points ) (x-request PolySegment - 1 66 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofSEGMENT segments + 1 66 opcode + 1 x unused + 2 3+2n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 8n LISTofSEGMENT segments ) (x-request PolyRectangle - 1 67 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles + 1 67 opcode + 1 x unused + 2 3+2n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 8n LISTofRECTANGLE rectangles ) (x-request PolyArc - 1 68 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs + 1 68 opcode + 1 x unused + 2 3+3n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 12n LISTofARC arcs ) (x-request FillPoly - 1 69 opcode - 1 x unused - 2 4+n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 1 (MEMBER complex nonconvex convex) shape - 1 (MEMBER origin previous) coordinate-mode - 2 x unused - 4n LISTofPOINT points + 1 69 opcode + 1 x unused + 2 4+n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 1 (MEMBER complex nonconvex convex) shape + 1 (MEMBER origin previous) coordinate-mode + 2 x unused + 4n LISTofPOINT points ) (x-request PolyFillRectangle - 1 70 opcode - 1 x unused - 2 3+2n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 8n LISTofRECTANGLE rectangles + 1 70 opcode + 1 x unused + 2 3+2n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 8n LISTofRECTANGLE rectangles ) (x-request PolyFillArc - 1 71 opcode - 1 x unused - 2 3+3n request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 12n LISTofARC arcs + 1 71 opcode + 1 x unused + 2 3+3n request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 12n LISTofARC arcs ) (x-request PutImage - 1 72 opcode - 1 (bitmap xypixmap zpixmap) format - 2 |6+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 CARD16 width - 2 CARD16 height - 2 INT16 dst-x - 2 INT16 dst-y - 1 CARD8 left-pad - 1 CARD8 depth - 2 x unused - n LISTofBYTE data - p x unused + 1 72 opcode + 1 (bitmap xypixmap zpixmap) format + 2 |6+(n+p)/4| request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 2 CARD16 width + 2 CARD16 height + 2 INT16 dst-x + 2 INT16 dst-y + 1 CARD8 left-pad + 1 CARD8 depth + 2 x unused + n LISTofBYTE data + p x unused ) (x-request GetImage - 1 73 opcode - 1 (MEMBER error xypixmap zpixmap) format - 2 5 request-length - 4 DRAWABLE drawable - 2 INT16 x - 2 INT16 y - 2 CARD16 width - 2 CARD16 height - 4 CARD32 plane-mask + 1 73 opcode + 1 (MEMBER error xypixmap zpixmap) format + 2 5 request-length + 4 DRAWABLE drawable + 2 INT16 x + 2 INT16 y + 2 CARD16 width + 2 CARD16 height + 4 CARD32 plane-mask ) (x-request PolyText8 - 1 74 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM8 items - p x unused + 1 74 opcode + 1 x unused + 2 |4+(n+p)/4| request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 2 INT16 x + 2 INT16 y + n LISTofTEXTITEM8 items + p x unused ) (x-request PolyText16 - 1 75 opcode - 1 x unused - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n LISTofTEXTITEM16 items - p x unused + 1 75 opcode + 1 x unused + 2 |4+(n+p)/4| request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 2 INT16 x + 2 INT16 y + n LISTofTEXTITEM16 items + p x unused ) (x-request ImageText8 - 1 76 opcode - 1 n length-of-string - 2 |4+(n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - n STRING8 string - p x unused + 1 76 opcode + 1 n length-of-string + 2 |4+(n+p)/4| request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 2 INT16 x + 2 INT16 y + n STRING8 string + p x unused ) (x-request ImageText16 - 1 77 opcode - 1 n number-of-CHAR2Bs-in-string - 2 |4+(2n+p)/4| request-length - 4 DRAWABLE drawable - 4 GCONTEXT gc - 2 INT16 x - 2 INT16 y - 2n STRING16 string - p x unused + 1 77 opcode + 1 n number-of-CHAR2Bs-in-string + 2 |4+(2n+p)/4| request-length + 4 DRAWABLE drawable + 4 GCONTEXT gc + 2 INT16 x + 2 INT16 y + 2n STRING16 string + p x unused ) (x-request CreateColormap - 1 78 opcode - 1 (MEMBER none all) alloc - 2 4 request-length - 4 COLORMAP mid - 4 WINDOW window - 4 VISUALID visual + 1 78 opcode + 1 (MEMBER none all) alloc + 2 4 request-length + 4 COLORMAP mid + 4 WINDOW window + 4 VISUALID visual ) (x-request FreeColormap - 1 79 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap + 1 79 opcode + 1 x unused + 2 2 request-length + 4 COLORMAP cmap ) (x-request CopyColormapAndFree - 1 80 opcode - 1 x unused - 2 3 request-length - 4 COLORMAP mid - 4 COLORMAP src-cmap + 1 80 opcode + 1 x unused + 2 3 request-length + 4 COLORMAP mid + 4 COLORMAP src-cmap ) (x-request InstallColormap - 1 81 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap + 1 81 opcode + 1 x unused + 2 2 request-length + 4 COLORMAP cmap ) (x-request UninstallColormap - 1 82 opcode - 1 x unused - 2 2 request-length - 4 COLORMAP cmap + 1 82 opcode + 1 x unused + 2 2 request-length + 4 COLORMAP cmap ) (x-request ListInstalledColormaps - 1 83 opcode - 1 x unused - 2 2 request-length - 4 WINDOW window + 1 83 opcode + 1 x unused + 2 2 request-length + 4 WINDOW window ) (x-request AllocColor - 1 84 opcode - 1 x unused - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 red - 2 CARD16 green - 2 CARD16 blue - 2 x unused + 1 84 opcode + 1 x unused + 2 4 request-length + 4 COLORMAP cmap + 2 CARD16 red + 2 CARD16 green + 2 CARD16 blue + 2 x unused ) (x-request AllocNamedColor - 1 85 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 85 opcode + 1 x unused + 2 |3+(n+p)/4| request-length + 4 COLORMAP cmap + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request AllocColorCells - 1 86 opcode - 1 BOOL contiguous - 2 3 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 planes + 1 86 opcode + 1 BOOL contiguous + 2 3 request-length + 4 COLORMAP cmap + 2 CARD16 colors + 2 CARD16 planes ) (x-request AllocColorPlanes - 1 87 opcode - 1 BOOL contiguous - 2 4 request-length - 4 COLORMAP cmap - 2 CARD16 colors - 2 CARD16 reds - 2 CARD16 greens - 2 CARD16 blues + 1 87 opcode + 1 BOOL contiguous + 2 4 request-length + 4 COLORMAP cmap + 2 CARD16 colors + 2 CARD16 reds + 2 CARD16 greens + 2 CARD16 blues ) (x-request FreeColors - 1 88 opcode - 1 x unused - 2 3+n request-length - 4 COLORMAP cmap - 4 CARD32 plane-mask - 4n LISTofCARD32 pixels + 1 88 opcode + 1 x unused + 2 3+n request-length + 4 COLORMAP cmap + 4 CARD32 plane-mask + 4n LISTofCARD32 pixels ) (x-request StoreColors - 1 89 opcode - 1 x unused - 2 2+3n request-length - 4 COLORMAP cmap - 12n LISTofCOLORITEM items + 1 89 opcode + 1 x unused + 2 2+3n request-length + 4 COLORMAP cmap + 12n LISTofCOLORITEM items ) (x-request StoreNamedColor - 1 90 opcode - 1 color-mask do-red_do-green_do-blue - 2 |4+(n+p)/4| request-length - 4 COLORMAP cmap - 4 CARD32 pixel - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 90 opcode + 1 color-mask do-red_do-green_do-blue + 2 |4+(n+p)/4| request-length + 4 COLORMAP cmap + 4 CARD32 pixel + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request QueryColors - 1 91 opcode - 1 x unused - 2 2+n request-length - 4 COLORMAP cmap - 4n LISTofCARD32 pixels + 1 91 opcode + 1 x unused + 2 2+n request-length + 4 COLORMAP cmap + 4n LISTofCARD32 pixels ) (x-request LookupColor - 1 92 opcode - 1 x unused - 2 |3+(n+p)/4| request-length - 4 COLORMAP cmap - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 92 opcode + 1 x unused + 2 |3+(n+p)/4| request-length + 4 COLORMAP cmap + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request CreateCursor - 1 93 opcode - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 PIXMAP source - 4 (OR (MEMBER none) PIXMAP) mask - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue - 2 CARD16 x - 2 CARD16 y + 1 93 opcode + 1 x unused + 2 8 request-length + 4 CURSOR cid + 4 PIXMAP source + 4 (OR (MEMBER none) PIXMAP) mask + 2 CARD16 fore-red + 2 CARD16 fore-green + 2 CARD16 fore-blue + 2 CARD16 back-red + 2 CARD16 back-green + 2 CARD16 back-blue + 2 CARD16 x + 2 CARD16 y ) (x-request CreateGlyphCursor - 1 94 CreateGlyphCursor - 1 x unused - 2 8 request-length - 4 CURSOR cid - 4 FONT source-font - 4 (OR (MEMBER none) FONT) mask-font - 2 CARD16 source-char - 2 CARD16 mask-char - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue + 1 94 CreateGlyphCursor + 1 x unused + 2 8 request-length + 4 CURSOR cid + 4 FONT source-font + 4 (OR (MEMBER none) FONT) mask-font + 2 CARD16 source-char + 2 CARD16 mask-char + 2 CARD16 fore-red + 2 CARD16 fore-green + 2 CARD16 fore-blue + 2 CARD16 back-red + 2 CARD16 back-green + 2 CARD16 back-blue ) (x-request FreeCursor - 1 95 opcode - 1 x unused - 2 2 request-length - 4 CURSOR cursor + 1 95 opcode + 1 x unused + 2 2 request-length + 4 CURSOR cursor ) (x-request RecolorCursor - 1 96 opcode - 1 x unused - 2 5 request-length - 4 CURSOR cursor - 2 CARD16 fore-red - 2 CARD16 fore-green - 2 CARD16 fore-blue - 2 CARD16 back-red - 2 CARD16 back-green - 2 CARD16 back-blue + 1 96 opcode + 1 x unused + 2 5 request-length + 4 CURSOR cursor + 2 CARD16 fore-red + 2 CARD16 fore-green + 2 CARD16 fore-blue + 2 CARD16 back-red + 2 CARD16 back-green + 2 CARD16 back-blue ) (x-request QueryBestSize - 1 97 opcode - 1 (MEMBER cursor tile stipple) class - 2 3 request-length - 4 DRAWABLE drawable - 2 CARD16 width - 2 CARD16 height + 1 97 opcode + 1 (MEMBER cursor tile stipple) class + 2 3 request-length + 4 DRAWABLE drawable + 2 CARD16 width + 2 CARD16 height ) (x-request QueryExtension - 1 98 opcode - 1 x unused - 2 |2+(n+p)/4| request-length - 2 n length-of-name - 2 x unused - n STRING8 name - p x unused + 1 98 opcode + 1 x unused + 2 |2+(n+p)/4| request-length + 2 n length-of-name + 2 x unused + n STRING8 name + p x unused ) (x-request ListExtensions - 1 99 opcode - 1 x unused - 2 1 request-length + 1 99 opcode + 1 x unused + 2 1 request-length ) (x-request SetKeyboardMapping - 1 100 opcode - 1 n keycode-count - 2 2+nm request-length - 1 KEYCODE first-keycode - 1 m keysyms-per-keycode - 2 x unused - 4nm LISTofKEYSYM keysyms + 1 100 opcode + 1 n keycode-count + 2 2+nm request-length + 1 KEYCODE first-keycode + 1 m keysyms-per-keycode + 2 x unused + 4nm LISTofKEYSYM keysyms ) (x-request GetKeyboardMapping - 1 101 opcode - 1 x unused - 2 2 request-length - 1 KEYCODE first-keycode - 1 CARD8 count - 2 x unused + 1 101 opcode + 1 x unused + 2 2 request-length + 1 KEYCODE first-keycode + 1 CARD8 count + 2 x unused ) (x-request ChangeKeyboardControl - 1 102 opcode - 1 x unused - 2 2+n request-length - 4 BITMASK value-mask - 4n LISTofVALUE value-list + 1 102 opcode + 1 x unused + 2 2+n request-length + 4 BITMASK value-mask + 4n LISTofVALUE value-list ) (x-request GetKeyboardControl - 1 103 opcode - 1 x unused - 2 1 request-length + 1 103 opcode + 1 x unused + 2 1 request-length ) (x-request Bell - 1 104 opcode - 1 INT8 percent - 2 1 request-length + 1 104 opcode + 1 INT8 percent + 2 1 request-length ) (x-request ChangePointerControl - 1 105 opcode - 1 x unused - 2 3 request-length - 2 INT16 acceleration-numerator - 2 INT16 acceleration-denominator - 2 INT16 threshold - 1 BOOL do-acceleration - 1 BOOL do-threshold + 1 105 opcode + 1 x unused + 2 3 request-length + 2 INT16 acceleration-numerator + 2 INT16 acceleration-denominator + 2 INT16 threshold + 1 BOOL do-acceleration + 1 BOOL do-threshold ) (x-request GetPointerControl - 1 106 GetPointerControl - 1 x unused - 2 1 request-length + 1 106 GetPointerControl + 1 x unused + 2 1 request-length ) (x-request SetScreenSaver - 1 107 opcode - 1 x unused - 2 3 request-length - 2 INT16 timeout - 2 INT16 interval - 1 (MEMBER no yes default) prefer-blanking - 1 (MEMBER no yes default) allow-exposures - 2 x unused + 1 107 opcode + 1 x unused + 2 3 request-length + 2 INT16 timeout + 2 INT16 interval + 1 (MEMBER no yes default) prefer-blanking + 1 (MEMBER no yes default) allow-exposures + 2 x unused ) (x-request GetScreenSaver - 1 108 opcode - 1 x unused - 2 1 request-length + 1 108 opcode + 1 x unused + 2 1 request-length ) (x-request ChangeHosts - 1 109 opcode - 1 (MEMBER insert delete) mode - 2 |2+(n+p)/4| request-length - 1 (MEMBER internet decnet chaos) family - 1 x unused - 2 CARD16 length-of-address - n LISTofCARD8 address - p x unused + 1 109 opcode + 1 (MEMBER insert delete) mode + 2 |2+(n+p)/4| request-length + 1 (MEMBER internet decnet chaos) family + 1 x unused + 2 CARD16 length-of-address + n LISTofCARD8 address + p x unused ) (x-request ListHosts - 1 110 opcode - 1 x unused - 2 1 request-length + 1 110 opcode + 1 x unused + 2 1 request-length ) (x-request ChangeAccessControl - 1 111 opcode - 1 (MEMBER disable enable) mode - 2 1 request-length + 1 111 opcode + 1 (MEMBER disable enable) mode + 2 1 request-length ) (x-request ChangeCloseDownMode - 1 112 opcode - 1 (MEMBER destroy retainpermanent retaintemporary) mode - 2 1 request-length + 1 112 opcode + 1 (MEMBER destroy retainpermanent retaintemporary) mode + 2 1 request-length ) (x-request KillClient - 1 113 opcode - 1 x unused - 2 2 request-length - 4 (MEMBER alltemporary CARD32) resource + 1 113 opcode + 1 x unused + 2 2 request-length + 4 (MEMBER alltemporary CARD32) resource ) (x-request RotateProperties - 1 114 opcode - 1 x unused - 2 3+n request-length - 4 WINDOW window - 2 n number-of-properties - 2 INT16 delta - 4n LISTofATOM properties + 1 114 opcode + 1 x unused + 2 3+n request-length + 4 WINDOW window + 2 n number-of-properties + 2 INT16 delta + 4n LISTofATOM properties ) (x-request ForceScreenSaver - 1 115 ForceScreenSaver - 1 (MEMBER reset activate) mode - 2 1 request-length + 1 115 ForceScreenSaver + 1 (MEMBER reset activate) mode + 2 1 request-length ) (x-request SetPointerMapping - 1 116 opcode - 1 n length-of-map - 2 |1+(n+p)/4| request-length - n LISTofCARD8 map - p x unused + 1 116 opcode + 1 n length-of-map + 2 |1+(n+p)/4| request-length + n LISTofCARD8 map + p x unused ) (x-request GetPointerMapping - 1 117 opcode - 1 x unused - 2 1 request-length + 1 117 opcode + 1 x unused + 2 1 request-length ) (x-request SetModifierMapping - 1 118 opcode - 1 KEYCODE Lock - 2 5 request-length - 1 KEYCODE Shift_A - 1 KEYCODE Shift_B - 1 KEYCODE Control_A - 1 KEYCODE Control_B - 1 KEYCODE Mod1_A - 1 KEYCODE Mod1_B - 1 KEYCODE Mod2_A - 1 KEYCODE Mod2_B - 1 KEYCODE Mod3_A - 1 KEYCODE Mod3_B - 1 KEYCODE Mod4_A - 1 KEYCODE Mod4_B - 1 KEYCODE Mod5_A - 1 KEYCODE Mod5_B - 2 x unused + 1 118 opcode + 1 KEYCODE Lock + 2 5 request-length + 1 KEYCODE Shift_A + 1 KEYCODE Shift_B + 1 KEYCODE Control_A + 1 KEYCODE Control_B + 1 KEYCODE Mod1_A + 1 KEYCODE Mod1_B + 1 KEYCODE Mod2_A + 1 KEYCODE Mod2_B + 1 KEYCODE Mod3_A + 1 KEYCODE Mod3_B + 1 KEYCODE Mod4_A + 1 KEYCODE Mod4_B + 1 KEYCODE Mod5_A + 1 KEYCODE Mod5_B + 2 x unused ) (x-request GetModifierMapping - 1 119 opcode - 1 x unused - 2 1 request-length + 1 119 opcode + 1 x unused + 2 1 request-length ) #+comment (x-request NoOperation - 1 127 opcode - 1 x unused - 2 1 request-length + 1 127 opcode + 1 x unused + 2 1 request-length ) ;; End of file diff --git a/src/clx/debug/event-test.lisp b/src/clx/debug/event-test.lisp index 5ded127ab..2d9a4dfe2 100644 --- a/src/clx/debug/event-test.lisp +++ b/src/clx/debug/event-test.lisp @@ -3,8 +3,8 @@ (in-package :xtest :use '(:xlib :lisp)) (defstruct event - key ; Event key - display ; Display event was reported to + key ; Event key + display ; Display event was reported to ;; The following are from the CLX event code state @@ -51,173 +51,173 @@ (defun process-input (display &optional timeout) "Process one event" - (declare (type display display) ; The display (from initialize-clue) - (type (or null number) timeout) ; optional timeout in seconds - (values (or null character))) ; Returns NIL only if timeout exceeded + (declare (type display display) ; The display (from initialize-clue) + (type (or null number) timeout) ; optional timeout in seconds + (values (or null character))) ; Returns NIL only if timeout exceeded (let ((event (make-event))) (setf (event-display event) display) (macrolet ((set-event (&rest parameters) - `(progn ,@(mapcar #'(lambda (parm) - `(setf (,(intern (concatenate 'string - (string 'event-) - (string parm))) - event) ,parm)) - parameters))) - (dispatch (contact) - `(dispatch-event event event-key send-event-p ,contact))) + `(progn ,@(mapcar #'(lambda (parm) + `(setf (,(intern (concatenate 'string + (string 'event-) + (string parm))) + event) ,parm)) + parameters))) + (dispatch (contact) + `(dispatch-event event event-key send-event-p ,contact))) (let ((result - (xlib:event-case (display :timeout timeout :force-output-p t) - ((:key-press :key-release :button-press :button-release) - (code time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event code time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - (:motion-notify - (hint-p time root window child root-x root-y x y - state same-screen-p event-key send-event-p) - (set-event hint-p time root window child root-x root-y x y - state same-screen-p) - (dispatch window)) - - ((:enter-notify :leave-notify) - (kind time root window child root-x root-y x y - state mode focus-p same-screen-p event-key send-event-p) - (set-event kind time root window child root-x root-y x y - state mode focus-p same-screen-p) - (dispatch window)) - - ((:focus-in :focus-out) - (kind window mode event-key send-event-p) - (set-event kind window mode) - (dispatch window)) - - (:keymap-notify - (window keymap event-key send-event-p) - (set-event window keymap) - (dispatch window)) - - (:exposure - (window x y width height count event-key send-event-p) - (set-event window x y width height count) - (dispatch window)) - - (:graphics-exposure - (drawable x y width height count major minor event-key send-event-p) - (set-event drawable x y width height count major minor) - (dispatch drawable)) - - (:no-exposure - (drawable major minor event-key send-event-p) - (set-event drawable major minor) - (dispatch drawable)) - - (:visibility-notify - (window state event-key send-event-p) - (set-event window state) - (dispatch window)) - - (:create-notify - (parent window x y width height border-width - override-redirect-p event-key send-event-p) - (set-event parent window x y width height border-width - override-redirect-p) - (dispatch parent)) - - (:destroy-notify - (event-window window event-key send-event-p) - (set-event event-window window) - (dispatch event-window)) - - (:unmap-notify - (event-window window configure-p event-key send-event-p) - (set-event event-window window configure-p) - (dispatch event-window)) - - (:map-notify - (event-window window override-redirect-p event-key send-event-p) - (set-event event-window window override-redirect-p) - (dispatch event-window)) - - (:map-request - (parent window event-key send-event-p) - (set-event parent window) - (dispatch parent)) - - (:reparent-notify - (event-window window parent x y override-redirect-p event-key send-event-p) - (set-event event-window window parent x y override-redirect-p) - (dispatch event-window)) - - (:configure-notify - (event-window window above-sibling x y width height border-width - override-redirect-p event-key send-event-p) - (set-event event-window window above-sibling x y width height - border-width override-redirect-p) - (dispatch event-window)) - - (:configure-request - (parent window above-sibling x y width height border-width event-key send-event-p) - (set-event parent window above-sibling x y width height border-width) - (dispatch parent)) - - (:gravity-notify - (event-window window x y event-key send-event-p) - (set-event event-window window x y) - (dispatch event-window)) - - (:resize-request - (window width height event-key send-event-p) - (set-event window width height) - (dispatch window)) - - (:circulate-notify - (event-window window parent place event-key send-event-p) - (set-event event-window window parent place) - (dispatch event-window)) - - (:circulate-request - (parent window place event-key send-event-p) - (set-event parent window place) - (dispatch parent)) - - (:property-notify - (window atom time state event-key send-event-p) - (set-event window atom time state) - (dispatch window)) - - (:selection-clear - (time window selection event-key send-event-p) - (set-event time window selection) - (dispatch window)) - - (:selection-request - (time window requestor selection target property event-key send-event-p) - (set-event time window requestor selection target property) - (dispatch window)) - - (:selection-notify - (time window selection target property event-key send-event-p) - (set-event time window selection target property) - (dispatch window)) - - (:colormap-notify - (window colormap new-p installed-p event-key send-event-p) - (set-event window colormap new-p installed-p) - (dispatch window)) - - (:client-message - (format window type data event-key send-event-p) - (set-event format window type data) - (dispatch window)) - - (:mapping-notify - (request start count) - (mapping-notify display request start count)) ;; Special case - ))) - (and result t))))) + (xlib:event-case (display :timeout timeout :force-output-p t) + ((:key-press :key-release :button-press :button-release) + (code time root window child root-x root-y x y + state same-screen-p event-key send-event-p) + (set-event code time root window child root-x root-y x y + state same-screen-p) + (dispatch window)) + + (:motion-notify + (hint-p time root window child root-x root-y x y + state same-screen-p event-key send-event-p) + (set-event hint-p time root window child root-x root-y x y + state same-screen-p) + (dispatch window)) + + ((:enter-notify :leave-notify) + (kind time root window child root-x root-y x y + state mode focus-p same-screen-p event-key send-event-p) + (set-event kind time root window child root-x root-y x y + state mode focus-p same-screen-p) + (dispatch window)) + + ((:focus-in :focus-out) + (kind window mode event-key send-event-p) + (set-event kind window mode) + (dispatch window)) + + (:keymap-notify + (window keymap event-key send-event-p) + (set-event window keymap) + (dispatch window)) + + (:exposure + (window x y width height count event-key send-event-p) + (set-event window x y width height count) + (dispatch window)) + + (:graphics-exposure + (drawable x y width height count major minor event-key send-event-p) + (set-event drawable x y width height count major minor) + (dispatch drawable)) + + (:no-exposure + (drawable major minor event-key send-event-p) + (set-event drawable major minor) + (dispatch drawable)) + + (:visibility-notify + (window state event-key send-event-p) + (set-event window state) + (dispatch window)) + + (:create-notify + (parent window x y width height border-width + override-redirect-p event-key send-event-p) + (set-event parent window x y width height border-width + override-redirect-p) + (dispatch parent)) + + (:destroy-notify + (event-window window event-key send-event-p) + (set-event event-window window) + (dispatch event-window)) + + (:unmap-notify + (event-window window configure-p event-key send-event-p) + (set-event event-window window configure-p) + (dispatch event-window)) + + (:map-notify + (event-window window override-redirect-p event-key send-event-p) + (set-event event-window window override-redirect-p) + (dispatch event-window)) + + (:map-request + (parent window event-key send-event-p) + (set-event parent window) + (dispatch parent)) + + (:reparent-notify + (event-window window parent x y override-redirect-p event-key send-event-p) + (set-event event-window window parent x y override-redirect-p) + (dispatch event-window)) + + (:configure-notify + (event-window window above-sibling x y width height border-width + override-redirect-p event-key send-event-p) + (set-event event-window window above-sibling x y width height + border-width override-redirect-p) + (dispatch event-window)) + + (:configure-request + (parent window above-sibling x y width height border-width event-key send-event-p) + (set-event parent window above-sibling x y width height border-width) + (dispatch parent)) + + (:gravity-notify + (event-window window x y event-key send-event-p) + (set-event event-window window x y) + (dispatch event-window)) + + (:resize-request + (window width height event-key send-event-p) + (set-event window width height) + (dispatch window)) + + (:circulate-notify + (event-window window parent place event-key send-event-p) + (set-event event-window window parent place) + (dispatch event-window)) + + (:circulate-request + (parent window place event-key send-event-p) + (set-event parent window place) + (dispatch parent)) + + (:property-notify + (window atom time state event-key send-event-p) + (set-event window atom time state) + (dispatch window)) + + (:selection-clear + (time window selection event-key send-event-p) + (set-event time window selection) + (dispatch window)) + + (:selection-request + (time window requestor selection target property event-key send-event-p) + (set-event time window requestor selection target property) + (dispatch window)) + + (:selection-notify + (time window selection target property event-key send-event-p) + (set-event time window selection target property) + (dispatch window)) + + (:colormap-notify + (window colormap new-p installed-p event-key send-event-p) + (set-event window colormap new-p installed-p) + (dispatch window)) + + (:client-message + (format window type data event-key send-event-p) + (set-event format window type data) + (dispatch window)) + + (:mapping-notify + (request start count) + (mapping-notify display request start count)) ;; Special case + ))) + (and result t))))) (defun event-case-test (display) ;; Tests universality of display, event-key, event-code, send-event-p and event-window diff --git a/src/clx/debug/keytrans.lisp b/src/clx/debug/keytrans.lisp index 333c1efa7..a1447b0b3 100644 --- a/src/clx/debug/keytrans.lisp +++ b/src/clx/debug/keytrans.lisp @@ -3,9 +3,9 @@ ;;; CLX keysym-translation test programs ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -32,41 +32,41 @@ (when (cdr (character->keysyms (int-char i))) (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) (dolist (keysym (character->keysyms (int-char i))) - (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) + (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (defun check-lowercase-keysyms () ;; Checks for keysyms with incorrect :lowercase parameters (maphash #'(lambda (key mapping) - (let* ((value (car mapping)) - (char (keysym-mapping-object value))) - (if (and (characterp char) (both-case-p char) - (= (char-int char) (char-int (char-upcase char)))) - ;; uppercase alphabetic character - (unless (eq (keysym-mapping-lowercase value) - (char-int (char-downcase char))) - (let ((lowercase (keysym-mapping-lowercase value)) - (should-be (char-downcase char))) - (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) lowercase)) - (and lowercase (ldb (byte 8 0) lowercase)) - (int-char lowercase) - (ldb (byte 8 8) (char-int should-be)) - (ldb (byte 8 0) (char-int should-be)) - should-be))) - (when (keysym-mapping-lowercase value) - (let ((lowercase (keysym-mapping-lowercase value))) - (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" - (ldb (byte 8 8) key) - (ldb (byte 8 0) key) - char - (and lowercase (ldb (byte 8 8) (char-int lowercase))) - (and lowercase (ldb (byte 8 0) (char-int lowercase))) - lowercase - )))))) - *keysym->character-map*)) + (let* ((value (car mapping)) + (char (keysym-mapping-object value))) + (if (and (characterp char) (both-case-p char) + (= (char-int char) (char-int (char-upcase char)))) + ;; uppercase alphabetic character + (unless (eq (keysym-mapping-lowercase value) + (char-int (char-downcase char))) + (let ((lowercase (keysym-mapping-lowercase value)) + (should-be (char-downcase char))) + (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" + (ldb (byte 8 8) key) + (ldb (byte 8 0) key) + char + (and lowercase (ldb (byte 8 8) lowercase)) + (and lowercase (ldb (byte 8 0) lowercase)) + (int-char lowercase) + (ldb (byte 8 8) (char-int should-be)) + (ldb (byte 8 0) (char-int should-be)) + should-be))) + (when (keysym-mapping-lowercase value) + (let ((lowercase (keysym-mapping-lowercase value))) + (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" + (ldb (byte 8 8) key) + (ldb (byte 8 0) key) + char + (and lowercase (ldb (byte 8 8) (char-int lowercase))) + (and lowercase (ldb (byte 8 0) (char-int lowercase))) + lowercase + )))))) + *keysym->character-map*)) (defun print-all-keysyms () (let ((all nil)) @@ -76,11 +76,11 @@ (dolist (keysym all) (format t "~%~3d ~3d~{ ~s~}" - (ldb (byte 8 8) (car keysym)) - (ldb (byte 8 0) (car keysym)) - (cadr keysym)) + (ldb (byte 8 8) (car keysym)) + (ldb (byte 8 0) (car keysym)) + (cadr keysym)) (dolist (mapping (cddr keysym)) - (format t "~%~7@t~{ ~s~}" mapping))))) + (format t "~%~7@t~{ ~s~}" mapping))))) (defun keysym-mappings (keysym &key display (mask-format #'identity)) ;; Return all the keysym mappings for keysym. @@ -89,146 +89,146 @@ ;; (dolist (mapping (keysym-mappings) keysym) ;; (apply #'define-keysym mapping)) (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (result nil)) + (gethash keysym *keysym->character-map*))) + (result nil)) (dolist (mapping mappings) (let ((object (keysym-mapping-object mapping)) - (translate (keysym-mapping-translate mapping)) - (lowercase (keysym-mapping-lowercase mapping)) - (modifiers (keysym-mapping-modifiers mapping)) - (mask (keysym-mapping-mask mapping))) - (push (append (list object keysym) - (when translate (list :translate translate)) - (when lowercase (list :lowercase lowercase)) - (when modifiers (list :modifiers (funcall mask-format modifiers))) - (when mask (list :mask (funcall mask-format mask)))) - result))) + (translate (keysym-mapping-translate mapping)) + (lowercase (keysym-mapping-lowercase mapping)) + (modifiers (keysym-mapping-modifiers mapping)) + (mask (keysym-mapping-mask mapping))) + (push (append (list object keysym) + (when translate (list :translate translate)) + (when lowercase (list :lowercase lowercase)) + (when modifiers (list :modifiers (funcall mask-format modifiers))) + (when mask (list :mask (funcall mask-format mask)))) + result))) (nreverse result))) #+comment (defun print-keysym-mappings (keysym &optional display) (format t "~%(keysym ~d ~3d) " - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym)) + (ldb (byte 8 8) keysym) + (ldb (byte 8 0) keysym)) (dolist (mapping (keysym-mappings keysym :display display)) (format t "~16t~{ ~s~}~%" mapping))) (defun print-keysym-mappings (keysym &optional display) (flet ((format-mask (mask) - (cond ((numberp mask) - `(make-state-mask ,@(make-state-keys mask))) - ((atom mask) mask) - (t `(list ,@(mapcar - #'(lambda (item) - (if (numberp item) - `(keysym ,(keysym-mapping-object - (car (gethash item *keysym->character-map*)))) - item)) - mask)))))) + (cond ((numberp mask) + `(make-state-mask ,@(make-state-keys mask))) + ((atom mask) mask) + (t `(list ,@(mapcar + #'(lambda (item) + (if (numberp item) + `(keysym ,(keysym-mapping-object + (car (gethash item *keysym->character-map*)))) + item)) + mask)))))) (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" - (car mapping) - (ldb (byte 8 8) keysym) - (ldb (byte 8 0) keysym) - (cdr mapping))))) + (car mapping) + (ldb (byte 8 8) keysym) + (ldb (byte 8 0) keysym) + (cdr mapping))))) (defun keysym-test (host) ;; Server key-press Loop-back test (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - #+comment - (gc (create-gcontext - :drawable win - :background black - :foreground white))) + (width 400) + (height 400) + (screen (display-default-screen display)) + (black (screen-black-pixel screen)) + (white (screen-white-pixel screen)) + (win (create-window + :parent (screen-root screen) + :background black + :border white + :border-width 1 + :colormap (screen-default-colormap screen) + :bit-gravity :center + :event-mask '(:exposure :key-press) + :x 20 :y 20 + :width width :height height)) + #+comment + (gc (create-gcontext + :drawable win + :background black + :foreground white))) (initialize-extensions display) - (map-window win) ; Map the window + (map-window win) ; Map the window ;; Handle events (unwind-protect - (dotimes (state 64) - (do ((code (display-min-keycode display) (1+ code))) - ((> code (display-max-keycode display))) - (send-event win :key-press '(:key-press) :code code :state state - :window win :root (screen-root screen) :time 0 - :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window)) - nil) - (key-press (display code state) - (princ (keycode->character display code state)) - t)))) + (dotimes (state 64) + (do ((code (display-min-keycode display) (1+ code))) + ((> code (display-max-keycode display))) + (send-event win :key-press '(:key-press) :code code :state state + :window win :root (screen-root screen) :time 0 + :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) + (event-case (display :force-output-p t :discard-p t) + (exposure ;; Come here on exposure events + (window count) + (when (zerop count) ;; Ignore all but the last exposure event + (clear-area window)) + nil) + (key-press (display code state) + (princ (keycode->character display code state)) + t)))) (close-display display)))) (defun keysym-echo (host &optional keymap-p) ;; Echo characters typed to a window (let* ((display (open-display host)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press :keymap-state :enter-window) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) + (width 400) + (height 400) + (screen (display-default-screen display)) + (black (screen-black-pixel screen)) + (white (screen-white-pixel screen)) + (win (create-window + :parent (screen-root screen) + :background black + :border white + :border-width 1 + :colormap (screen-default-colormap screen) + :bit-gravity :center + :event-mask '(:exposure :key-press :keymap-state :enter-window) + :x 20 :y 20 + :width width :height height)) + (gc (create-gcontext + :drawable win + :background black + :foreground white))) (initialize-extensions display) - (map-window win) ; Map the window + (map-window win) ; Map the window ;; Handle events (unwind-protect - (event-case (display :force-output-p t :discard-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-glyphs window gc 10 10 "Press to exit")) - nil) - (key-press (display code state) - (let ((char (keycode->character display code state))) - (format t "~%Code: ~s State: ~s Char: ~s" code state char) - ;; (PRINC char) (PRINC " ") - (when keymap-p - (let ((keymap (query-keymap display))) - (unless (character-in-map-p display char keymap) - (print "character-in-map-p failed") - (print-keymap keymap)))) - ;; (when (eql char #\0) (setq disp display) (break)) - (eql char #\escape))) - (keymap-notify (keymap) - (print "Keymap-notify") ;; we never get here. Server bug? - (when (keysym-in-map-p display 65 keymap) - (print "Found A")) - (when (character-in-map-p display #\b keymap) - (print "Found B"))) - (enter-notify (event-window) (format t "~%Enter ~s" event-window))) + (event-case (display :force-output-p t :discard-p t) + (exposure ;; Come here on exposure events + (window count) + (when (zerop count) ;; Ignore all but the last exposure event + (clear-area window) + (draw-glyphs window gc 10 10 "Press to exit")) + nil) + (key-press (display code state) + (let ((char (keycode->character display code state))) + (format t "~%Code: ~s State: ~s Char: ~s" code state char) + ;; (PRINC char) (PRINC " ") + (when keymap-p + (let ((keymap (query-keymap display))) + (unless (character-in-map-p display char keymap) + (print "character-in-map-p failed") + (print-keymap keymap)))) + ;; (when (eql char #\0) (setq disp display) (break)) + (eql char #\escape))) + (keymap-notify (keymap) + (print "Keymap-notify") ;; we never get here. Server bug? + (when (keysym-in-map-p display 65 keymap) + (print "Found A")) + (when (character-in-map-p display #\b keymap) + (print "Found B"))) + (enter-notify (event-window) (format t "~%Enter ~s" event-window))) (close-display display)))) (defun print-keymap (keymap) @@ -236,28 +236,28 @@ ((>= j 256)) (format t "~% ~3d: " j) (do ((i j (1+ i))) - ((>= i (+ j 32))) - (when (zerop (logand i 7)) - (princ " ")) - (princ (aref keymap i))))) + ((>= i (+ j 32))) + (when (zerop (logand i 7)) + (princ " ")) + (princ (aref keymap i))))) (defun define-keysym-test (&key display printp - (modifiers (list (keysym :left-meta))) (mask :modifiers)) + (modifiers (list (keysym :left-meta))) (mask :modifiers)) (let* ((keysym 067) - (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) - (original (copy-tree (keysym-mappings keysym :display display)))) + (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) + (original (copy-tree (keysym-mappings keysym :display display)))) (when printp (print-keysym-mappings 67) (terpri)) (apply #'define-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display)) - (should-be (append original (list args)))) + (should-be (append original (list args)))) (unless (equal is should-be) - (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) + (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) (apply #'undefine-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display))) (unless (equal is original) - (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) + (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) (define-keysym-test) (define-keysym-test :modifiers (make-state-mask :shift :lock)) diff --git a/src/clx/debug/trace.lisp b/src/clx/debug/trace.lisp index 276e2f56b..a16e180c2 100644 --- a/src/clx/debug/trace.lisp +++ b/src/clx/debug/trace.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -36,16 +36,16 @@ (eval-when (load eval) (export '(trace-display - suspend-display-tracing - resume-display-tracing - untrace-display - show-trace - display-trace ; for backwards compatibility - describe-request - describe-event - describe-reply - describe-error - describe-trace))) + suspend-display-tracing + resume-display-tracing + untrace-display + show-trace + display-trace ; for backwards compatibility + describe-request + describe-event + describe-reply + describe-error + describe-trace))) (defun trace-display (display) "Start a trace on DISPLAY. @@ -69,8 +69,8 @@ "Used to resume tracing after suspending" (if (getf (display-plist display) 'suspend-display-tracing) (progn - (bind-io-hooks display) - (remf (display-plist display) 'suspend-display-tracing)) + (bind-io-hooks display) + (remf (display-plist display) 'suspend-display-tracing)) (warn "Tracing was not suspended for ~s" display))) (defun untrace-display (display) @@ -84,26 +84,26 @@ ;; Assumes tracing is not already on. (defun bind-io-hooks (display) (let ((write-function (display-write-function display)) - (input-function (display-input-function display))) + (input-function (display-input-function display))) ;; Save origional write/input functions so we can untrace (setf (getf (display-plist display) 'write-function) write-function) (setf (getf (display-plist display) 'input-function) input-function) ;; Set new write/input functions that will record what's sent to the server (setf (display-write-function display) #'(lambda (vector display start end) - (trace-write-hook vector display start end) - (funcall write-function vector display start end))) + (trace-write-hook vector display start end) + (funcall write-function vector display start end))) (setf (display-input-function display) #'(lambda (display vector start end timeout) - (let ((result (funcall input-function - display vector start end timeout))) - (unless result - (trace-read-hook display vector start end)) - result))))) + (let ((result (funcall input-function + display vector start end timeout))) + (unless result + (trace-read-hook display vector start end)) + result))))) (defun unbind-io-hooks (display) (let ((write-function (getf (display-plist display) 'write-function)) - (input-function (getf (display-plist display) 'input-function))) + (input-function (getf (display-plist display) 'input-function))) (when write-function (setf (display-write-function display) write-function)) (when input-function @@ -115,112 +115,112 @@ (defun byte-ref16 (vector index) #+clx-little-endian (logior (the card16 - (ash (the card8 (aref vector (index+ index 1))) 8)) - (the card8 - (aref vector index))) + (ash (the card8 (aref vector (index+ index 1))) 8)) + (the card8 + (aref vector index))) #-clx-little-endian (logior (the card16 - (ash (the card8 (aref vector index)) 8)) - (the card8 - (aref vector (index+ index 1))))) + (ash (the card8 (aref vector index)) 8)) + (the card8 + (aref vector (index+ index 1))))) (defun byte-ref32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (values card32)) (declare-buffun) #+clx-little-endian (the card32 (logior (the card32 - (ash (the card8 (aref a (index+ i 3))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 2))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 1))) 8)) - (the card8 - (aref a i)))) + (ash (the card8 (aref a (index+ i 3))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i 2))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i 1))) 8)) + (the card8 + (aref a i)))) #-clx-little-endian (the card32 (logior (the card32 - (ash (the card8 (aref a i)) 24)) - (the card29 - (ash (the card8 (aref a (index+ i 1))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i 2))) 8)) - (the card8 - (aref a (index+ i 3)))))) + (ash (the card8 (aref a i)) 24)) + (the card29 + (ash (the card8 (aref a (index+ i 1))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i 2))) 8)) + (the card8 + (aref a (index+ i 3)))))) (defun trace-write-hook (vector display start end) ;; Called only by buffer-flush. Start should always be 0 (unless (zerop start) (format *debug-io* "write-called with non-zero start: ~d" start)) (let* ((history (display-trace-history display)) - (request-number (display-request-number display)) - (last-history (car history))) + (request-number (display-request-number display)) + (last-history (car history))) ;; There may be several requests in the buffer, and the last one may be ;; incomplete. The first one may be the completion of a previous request. ;; We can detect incomplete requests by comparing the expected length of ;; the last request with the actual length. (when (and last-history (numberp (caar last-history))) (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - ;; Last history incomplete - append to last - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length)))) + (append-length (min (- last-length (length (cdr last-history))) + (- end start)))) + (when (plusp append-length) + ;; Last history incomplete - append to last + (setf (cdr last-history) + (concatenate '(vector card8) (cdr last-history) + (subseq vector start (+ start append-length)))) + (index-incf start append-length)))) ;; Copy new requests into the history (do* ((new-history nil) - (i start (+ i length)) - request - length) - ((>= i end) - ;; add in sequence numbers - (dolist (entry new-history) - (setf (caar entry) request-number) - (decf request-number)) - (setf (display-trace-history display) - (nconc new-history history))) + (i start (+ i length)) + request + length) + ((>= i end) + ;; add in sequence numbers + (dolist (entry new-history) + (setf (caar entry) request-number) + (decf request-number)) + (setf (display-trace-history display) + (nconc new-history history))) (setq request (aref vector i)) (setq length (index* 4 (byte-ref16 vector (+ i 2)))) (when (zerop length) - (warn "Zero length in buffer") - (return nil)) + (warn "Zero length in buffer") + (return nil)) (push (cons (cons 0 (trace-more-info display request vector - i (min (+ i length) end))) - (subseq vector i (min (+ i length) end))) new-history) + i (min (+ i length) end))) + (subseq vector i (min (+ i length) end))) new-history) (when (zerop request) - (warn "Zero length in buffer") - (return nil))))) + (warn "Zero length in buffer") + (return nil))))) (defun trace-read-hook (display vector start end) ;; Reading is done with an initial length of 32 (with start = 0) ;; This may be followed by several other reads for long replies. (let* ((history (display-trace-history display)) - (last-history (car history)) - (length (- end start))) + (last-history (car history)) + (length (- end start))) (when (and history (eq (caar last-history) :reply)) (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4)))) - (append-length (min (- last-length (length (cdr last-history))) - (- end start)))) - (when (plusp append-length) - (setf (cdr last-history) - (concatenate '(vector card8) (cdr last-history) - (subseq vector start (+ start append-length)))) - (index-incf start append-length) - (index-decf length append-length)))) + (append-length (min (- last-length (length (cdr last-history))) + (- end start)))) + (when (plusp append-length) + (setf (cdr last-history) + (concatenate '(vector card8) (cdr last-history) + (subseq vector start (+ start append-length)))) + (index-incf start append-length) + (index-decf length append-length)))) ;; Copy new requests into the history (when (plusp length) (let ((reply-type (case (aref vector start) (0 :error) (1 :reply) - (otherwise :event)))) - (push (cons (cons reply-type - (trace-more-info display reply-type vector start - (+ start length))) - (subseq vector start (+ start length))) - (display-trace-history display)))))) + (otherwise :event)))) + (push (cons (cons reply-type + (trace-more-info display reply-type vector start + (+ start length))) + (subseq vector start (+ start length))) + (display-trace-history display)))))) (defun trace-more-info (display request-id vector start end) ;; Currently only returns current process. @@ -235,41 +235,41 @@ displayed." (declare (type display display)) (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) + 0 length))) (let* ((id (caar hist)) - (more-info (cdar hist)) - (vector (cdr hist)) - (length (length vector)) - (request (aref vector 0))) + (more-info (cdar hist)) + (vector (cdr hist)) + (length (length vector)) + (request (aref vector 0))) (format t "~%~5d " id) (case id - (:error - (trace-error-print display more-info vector)) - (:event - (format t "~a (~d) Sequence ~d" - (if (< request (length *event-key-vector*)) - (aref *event-key-vector* request) - "Unknown") - request - (byte-ref16 vector 2)) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))) - (otherwise - (format t "~a (~d) length ~d" - (request-name request) request length) - (when show-process - #+allegro - (format t ", Proc ~a" (mp::process-name (car more-info))))))))) + (:error + (trace-error-print display more-info vector)) + (:event + (format t "~a (~d) Sequence ~d" + (if (< request (length *event-key-vector*)) + (aref *event-key-vector* request) + "Unknown") + request + (byte-ref16 vector 2)) + (when show-process + #+allegro + (format t ", Proc ~a" (mp::process-name (car more-info))))) + (:reply + (format t "To ~d length ~d" + (byte-ref16 vector 2) length) + (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) + (unless (= length actual-length) + (format t " Should be ~d **************" actual-length))) + (when show-process + #+allegro + (format t ", Proc ~a" (mp::process-name (car more-info))))) + (otherwise + (format t "~a (~d) length ~d" + (request-name request) request length) + (when show-process + #+allegro + (format t ", Proc ~a" (mp::process-name (car more-info))))))))) ;; For backwards compatibility (defun display-trace (&rest args) @@ -278,144 +278,144 @@ (defun find-trace (display type sequence &optional (number 0)) (dolist (history (display-trace-history display)) (when (and (symbolp (caar history)) - (= (logandc2 (aref (cdr history) 0) 128) type) - (= (byte-ref16 (cdr history) 2) sequence) - (minusp (decf number))) + (= (logandc2 (aref (cdr history) 0) 128) type) + (= (byte-ref16 (cdr history) 2) sequence) + (minusp (decf number))) (return (cdr history))))) (defun describe-error (display sequence) "Describe the error associated with request SEQUENCE." (let ((vector (find-trace display 0 sequence))) (if vector - (progn - (terpri) - (trace-error-print display nil vector)) + (progn + (terpri) + (trace-error-print display nil vector)) (format t "Error with sequence ~d not found." sequence)))) (defun trace-error-print (display more-info vector - &optional (stream *standard-output*)) + &optional (stream *standard-output*)) (let ((event (allocate-event))) ;; Copy into event from reply buffer (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) + vector + 0 + *replysize*) (reading-event (event) (let* ((type (read-card8 0)) - (error-code (read-card8 1)) - (sequence (read-card16 2)) - (resource-id (read-card32 4)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (current-sequence (ldb (byte 16 0) (buffer-request-number display))) - (error-key - (if (< error-code (length *xerror-vector*)) - (aref *xerror-vector* error-code) - 'unknown-error)) - (params - (case error-key - ((colormap-error cursor-error drawable-error font-error gcontext-error - id-choice-error pixmap-error window-error) - (list :resource-id resource-id)) - (atom-error - (list :atom-id resource-id)) - (value-error - (list :value resource-id)) - (unknown-error - ;; Prevent errors when handler is a sequence - (setq error-code 0) - (list :error-code error-code))))) - type - (let ((condition - (apply #+lispm #'si:make-condition - #+allegro #'make-condition - #-(or lispm allegro) #'make-condition - error-key - :error-key error-key - :display display - :major major-code - :minor minor-code - :sequence sequence - :current-sequence current-sequence - params))) - (princ condition stream) - (deallocate-event event) - condition))))) + (error-code (read-card8 1)) + (sequence (read-card16 2)) + (resource-id (read-card32 4)) + (minor-code (read-card16 8)) + (major-code (read-card8 10)) + (current-sequence (ldb (byte 16 0) (buffer-request-number display))) + (error-key + (if (< error-code (length *xerror-vector*)) + (aref *xerror-vector* error-code) + 'unknown-error)) + (params + (case error-key + ((colormap-error cursor-error drawable-error font-error gcontext-error + id-choice-error pixmap-error window-error) + (list :resource-id resource-id)) + (atom-error + (list :atom-id resource-id)) + (value-error + (list :value resource-id)) + (unknown-error + ;; Prevent errors when handler is a sequence + (setq error-code 0) + (list :error-code error-code))))) + type + (let ((condition + (apply #+lispm #'si:make-condition + #+allegro #'make-condition + #-(or lispm allegro) #'make-condition + error-key + :error-key error-key + :display display + :major major-code + :minor minor-code + :sequence sequence + :current-sequence current-sequence + params))) + (princ condition stream) + (deallocate-event event) + condition))))) (defun describe-request (display sequence) "Describe the request with sequence number SEQUENCE" #+ti (si:load-if "clx:debug;describe") (let ((request (assoc sequence (display-trace-history display) - :test #'(lambda (item key) - (eql item (car key)))))) + :test #'(lambda (item key) + (eql item (car key)))))) (if (null request) - (format t "~%Request number ~d not found in trace history" sequence) + (format t "~%Request number ~d not found in trace history" sequence) (let* ((vector (cdr request)) - (len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))) + (len (length vector)) + (hist (make-reply-buffer len))) + (buffer-replace (reply-ibuf8 hist) vector 0 len) + (print-history-description hist))))) (defun describe-reply (display sequence) "Print the reply to request SEQUENCE. (The current implementation doesn't print very pretty)" (let ((vector (find-trace display 1 sequence)) - (*print-array* t)) + (*print-array* t)) (if vector - (print vector) + (print vector) (format t "~%Reply not found")))) (defun event-number (name) (if (integerp name) (let ((name (logandc2 name 128))) - (if (typep name '(integer 0 63)) - (aref *event-key-vector* name)) - name) + (if (typep name '(integer 0 63)) + (aref *event-key-vector* name)) + name) (position (string name) *event-key-vector* :test #'equalp :key #'string))) (defun describe-event (display name sequence &optional (number 0)) "Describe the event with event-name NAME and sequence number SEQUENCE. If there is more than one event, return NUMBER in the sequence." (declare (type display display) - (type (or stringable (integer 0 63)) name) - (integer sequence)) + (type (or stringable (integer 0 63)) name) + (integer sequence)) (let* ((event (event-number name)) - (vector (and event (find-trace display event sequence number)))) + (vector (and event (find-trace display event sequence number)))) (if (not event) - (format t "~%~s isn't an event name" name) + (format t "~%~s isn't an event name" name) (if (not vector) - (if (and (plusp number) (setq vector (find-trace display event sequence 0))) - (do ((i 1 (1+ i)) - (last-vector)) - (nil) - (if (setq vector (find-trace display event sequence i)) - (setq last-vector vector) - (progn - (format t "~%Event number ~d not found, last event was ~d" - number (1- i)) - (return (trace-event-print display last-vector))))) - (format t "~%Event ~s not found" - (aref *event-key-vector* event))) - (trace-event-print display vector))))) + (if (and (plusp number) (setq vector (find-trace display event sequence 0))) + (do ((i 1 (1+ i)) + (last-vector)) + (nil) + (if (setq vector (find-trace display event sequence i)) + (setq last-vector vector) + (progn + (format t "~%Event number ~d not found, last event was ~d" + number (1- i)) + (return (trace-event-print display last-vector))))) + (format t "~%Event ~s not found" + (aref *event-key-vector* event))) + (trace-event-print display vector))))) (defun trace-event-print (display vector) (let* ((event (allocate-event)) - (event-code (ldb (byte 7 0) (aref vector 0))) - (event-decoder (aref *event-handler-vector* event-code))) + (event-code (ldb (byte 7 0) (aref vector 0))) + (event-decoder (aref *event-handler-vector* event-code))) ;; Copy into event from reply buffer (setf (event-code event) event-code) (buffer-replace (reply-ibuf8 event) - vector - 0 - *replysize*) + vector + 0 + *replysize*) (prog1 (funcall event-decoder display event - #'(lambda (&rest args &key send-event-p &allow-other-keys) - (setq args (copy-list args)) - (remf args :display) - (remf args :event-code) - (unless send-event-p (remf args :send-event-p)) - args)) - (deallocate-event event)))) + #'(lambda (&rest args &key send-event-p &allow-other-keys) + (setq args (copy-list args)) + (remf args :display) + (remf args :event-code) + (unless send-event-p (remf args :send-event-p)) + args)) + (deallocate-event event)))) (defun describe-trace (display &optional length) "Display the trace history for DISPLAY. @@ -425,32 +425,32 @@ If there is more than one event, return NUMBER in the sequence." (declare (type display display)) #+ti (si:load-if "clx:debug;describe") (dolist (hist (reverse (subseq (display-trace-history display) - 0 length))) + 0 length))) (let* ((id (car hist)) - (vector (cdr hist)) - (length (length vector))) + (vector (cdr hist)) + (length (length vector))) (format t "~%~5d " id) (case id - (:error - (trace-error-print display nil vector)) - (:event - (let ((event (trace-event-print display vector))) - (when event (format t "from ~d ~{ ~s~}" - (byte-ref16 vector 2) event)))) - (:reply - (format t "To ~d length ~d" - (byte-ref16 vector 2) length) - (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) - (unless (= length actual-length) - (format t " Should be ~d **************" actual-length))) - (let ((*print-array* t) - (*print-base* 16.)) - (princ " ") - (princ vector))) - (otherwise - (let* ((len (length vector)) - (hist (make-reply-buffer len))) - (buffer-replace (reply-ibuf8 hist) vector 0 len) - (print-history-description hist))))))) + (:error + (trace-error-print display nil vector)) + (:event + (let ((event (trace-event-print display vector))) + (when event (format t "from ~d ~{ ~s~}" + (byte-ref16 vector 2) event)))) + (:reply + (format t "To ~d length ~d" + (byte-ref16 vector 2) length) + (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) + (unless (= length actual-length) + (format t " Should be ~d **************" actual-length))) + (let ((*print-array* t) + (*print-base* 16.)) + (princ " ") + (princ vector))) + (otherwise + (let* ((len (length vector)) + (hist (make-reply-buffer len))) + (buffer-replace (reply-ibuf8 hist) vector 0 len) + (print-history-description hist))))))) ;; End of file diff --git a/src/clx/debug/util.lisp b/src/clx/debug/util.lisp index 7db6be640..be78e2203 100644 --- a/src/clx/debug/util.lisp +++ b/src/clx/debug/util.lisp @@ -3,9 +3,9 @@ ;; CLX utilities ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -23,16 +23,16 @@ (in-package :xlib) (export '(display-root - display-black - display-white - report-events - describe-window - describe-gc - degree - radian - display-refresh - root-tree - window-tree)) + display-black + display-white + report-events + describe-window + describe-gc + degree + radian + display-refresh + root-tree + window-tree)) (defun display-root (display) (screen-root (display-default-screen display))) (defun display-black (display) (screen-black-pixel (display-default-screen display))) @@ -46,31 +46,31 @@ (defun describe-window (window) (macrolet ((da (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'window-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) - (dg (attribute &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'drawable-) - (string attribute)) 'xlib))) - `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) + (let ((func (intern (concatenate 'string (string 'window-) + (string attribute)) 'xlib))) + `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) + (dg (attribute &key (transform 'progn) (format "~s")) + (let ((func (intern (concatenate 'string (string 'drawable-) + (string attribute)) 'xlib))) + `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) (with-state (window) (when (window-p window) - (da visual :format "#x~x") - (da class) - (da gravity) - (da bit-gravity) - (da backing-store) - (da backing-planes :format "#x~x") - (da backing-pixel) - (da save-under) - (da colormap) - (da colormap-installed-p) - (da map-state) - (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") - (da override-redirect) - ) + (da visual :format "#x~x") + (da class) + (da gravity) + (da bit-gravity) + (da backing-store) + (da backing-planes :format "#x~x") + (da backing-pixel) + (da save-under) + (da colormap) + (da colormap-installed-p) + (da map-state) + (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") + (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") + (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") + (da override-redirect) + ) (dg root) (dg depth) (dg x) @@ -83,9 +83,9 @@ (defun describe-gc (gc) (macrolet ((dgc (name &key (transform 'progn) (format "~s")) - (let ((func (intern (concatenate 'string (string 'gcontext-) - (string name)) 'xlib))) - `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) + (let ((func (intern (concatenate 'string (string 'gcontext-) + (string name)) 'xlib))) + `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) (dgc function) (dgc plane-mask) (dgc foreground) @@ -122,21 +122,21 @@ ;; Useful for when the system writes to the screen (sometimes scrolling!) (let ((display (open-display host))) (unwind-protect - (let ((screen (display-default-screen display))) - (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on - :width (screen-width screen) :height (screen-height screen) - :background (screen-black-pixel screen)))) - (map-window win) - (display-finish-output display) - (unmap-window win) - (destroy-window win) - (display-finish-output display))) + (let ((screen (display-default-screen display))) + (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on + :width (screen-width screen) :height (screen-height screen) + :background (screen-black-pixel screen)))) + (map-window win) + (display-finish-output display) + (unmap-window win) + (destroy-window win) + (display-finish-output display))) (close-display display)))) (defun root-tree (host) (let ((display (open-display host))) (unwind-protect - (window-tree (screen-root (display-default-screen display))) + (window-tree (screen-root (display-default-screen display))) (close-display display))) (values)) @@ -144,21 +144,21 @@ ;; Print the window tree and properties starting from WINDOW ;; Returns a list of windows in the order that they are printed. (declare (arglist window) - (type window window) - (values (list window))) + (type window window) + (values (list window))) (let ((props (mapcar #'(lambda (prop) - (multiple-value-bind (data type format) - (get-property window prop) - (case type - (:string (setq data (coerce data 'string)))) - (list prop format type data))) - (list-properties window))) - (result (list window))) + (multiple-value-bind (data type format) + (get-property window prop) + (case type + (:string (setq data (coerce data 'string)))) + (list prop format type data))) + (list-properties window))) + (result (list window))) (with-state (window) (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window) - (drawable-x window) (drawable-y window) - (drawable-width window) (drawable-height window) - (window-map-state window))) + (drawable-x window) (drawable-y window) + (drawable-width window) (drawable-height window) + (window-map-state window))) (dolist (prop props) (format t "~%~v@t~{~s ~}" (+ depth 2) prop)) (dolist (w (query-tree window)) diff --git a/src/clx/defsystem.lisp b/src/clx/defsystem.lisp index bec62aaf7..e6dfc978d 100644 --- a/src/clx/defsystem.lisp +++ b/src/clx/defsystem.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. ;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. @@ -110,10 +110,10 @@ (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load graphics (:fasload package depdefs clx dependent macros fonts bufmac buffer display - fonts)) + fonts)) (:compile-load text (:fasload package depdefs clx dependent macros fonts bufmac buffer display - gcontext fonts)) + gcontext fonts)) (:compile-load-init attributes (dependent) (:fasload package depdefs clx dependent macros bufmac buffer display)) @@ -121,7 +121,7 @@ (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load keysyms (:fasload package depdefs clx dependent macros bufmac buffer display - translate)) + translate)) (:compile-load manager (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load image @@ -142,7 +142,7 @@ :distribute-binaries t :source-category :basic) (:module doc ("doc") - (:type :lisp-example)) + (:type :lisp-example)) (:serial "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" @@ -159,7 +159,7 @@ :source-category :basic :default-module-type :minima-lisp) (:module doc ("doc") - (:type :lisp-example)) + (:type :lisp-example)) (:serial "package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" @@ -176,9 +176,9 @@ #+excl (setq compiler::generate-interrupt-checks-switch (compile nil - '(lambda (safety size speed &optional debug) - (declare (ignore size debug)) - (or (< speed 3) (> safety 0))))) + '(lambda (safety size speed &optional debug) + (declare (ignore size debug)) + (or (< speed 3) (> safety 0))))) ;;; Allegro @@ -204,77 +204,77 @@ :recompile-on (|dependent|)) (|macros| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac|) + |exclcmac|) :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros|) + |exclcmac| |macros|) :recompile-on (|macros|)) (|buffer| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac|) + |exclcmac| |macros| |bufmac|) :recompile-on (|bufmac|)) (|display| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer|) + |exclcmac| |macros| |bufmac| |buffer|) :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|input| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|requests| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |input|) + |exclcmac| |macros| |bufmac| |buffer| |display| + |input|) :recompile-on (|display|)) (|fonts| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|graphics| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |fonts|) + |exclcmac| |macros| |bufmac| |buffer| |display| + |fonts|) :recompile-on (|fonts|)) (|text| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |gcontext| |fonts|) + |exclcmac| |macros| |bufmac| |buffer| |display| + |gcontext| |fonts|) :recompile-on (|gcontext| |fonts|) :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|translate| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |text|) + |exclcmac| |macros| |bufmac| |buffer| |display| + |text|) :recompile-on (|display|)) (|keysyms| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display| - |translate|) + |exclcmac| |macros| |bufmac| |buffer| |display| + |translate|) :recompile-on (|translate|)) (|manager| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|image| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| - |exclcmac| |macros| |bufmac| |buffer| |display|) + |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ) @@ -337,18 +337,18 @@ (declare (ignore binary-path)) #+(or cmu sbcl) (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) - c-call:int + c-call:int (host c-call:c-string) (port c-call:int)) #+(or kcl ibcl) (progn (let ((pathname (merge-pathnames "sockcl.o" binary-path)) - (options - (concatenate - 'string - (namestring (merge-pathnames "socket.o" binary-path)) - " -lc"))) + (options + (concatenate + 'string + (namestring (merge-pathnames "socket.o" binary-path)) + " -lc"))) (format t "~&Faslinking ~A with ~A.~%" pathname options) (si:faslink (namestring pathname) options) (format t "~&Finished faslinking ~A.~%" pathname))) @@ -356,36 +356,36 @@ #-(or lispm allegro Minima) (defun compile-clx (&optional - (source-pathname-defaults "") - (binary-pathname-defaults "") - &key - (compile-c t)) + (source-pathname-defaults "") + (binary-pathname-defaults "") + &key + (compile-c t)) ;; The pathname-defaults above might only be strings, so coerce them ;; to pathnames. Build a default binary path with every component ;; of the source except the file type. This should prevent ;; (compile-clx "*.lisp") from destroying source files. (let* ((source-path (pathname source-pathname-defaults)) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - #+clx-ansi-common-lisp (*compile-verbose* t) - (*load-verbose* t)) - + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path)) + #+clx-ansi-common-lisp (*compile-verbose* t) + (*load-verbose* t)) + ;; Make sure source-path and binary-path file types are distinct so ;; we don't accidently overwrite the source files. NIL should be an ;; ok type, but anything else spells trouble. (if (and (equal (pathname-type source-path) - (pathname-type binary-path)) - (not (null (pathname-type binary-path)))) - (error "Source and binary pathname defaults have same type ~s ~s" - source-path binary-path)) + (pathname-type binary-path)) + (not (null (pathname-type binary-path)))) + (error "Source and binary pathname defaults have same type ~s ~s" + source-path binary-path)) (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) @@ -393,55 +393,55 @@ #+lcl3.0 (progn (unless (member :pqc *features*) - (cerror - "Go ahead anyway." - "Lucid's production mode compiler must be loaded to compile CLX.")) + (cerror + "Go ahead anyway." + "Lucid's production mode compiler must be loaded to compile CLX.")) (proclaim '(optimize (speed 3) - (safety 1) - (space 0) - (compilation-speed 0)))) + (safety 1) + (space 0) + (compilation-speed 0)))) (labels ((compile-lisp (filename) - (let ((source (merge-pathnames filename source-path)) - (binary (merge-pathnames filename binary-path))) - ;; If the source and binary pathnames are the same, - ;; then don't supply an output file just to be sure - ;; compile-file defaults correctly. - #+(or kcl ibcl) (load source) - (if (equal source binary) - (compile-file source) - (compile-file source :output-file binary)) - binary)) - (compile-and-load (filename) - (load (compile-lisp filename))) - #+(or lucid kcl ibcl) - (compile-c (filename) - (let* ((c-filename (concatenate 'string filename ".c")) - (o-filename (concatenate 'string filename ".o")) - (src (merge-pathnames c-filename source-path)) - (obj (merge-pathnames o-filename binary-path)) - (args (list "-c" (namestring src) - "-o" (namestring obj) - #+mips "-G 0" - #+(or hp sysv) "-DSYSV" - #+(and mips (not dec)) "-I/usr/include/bsd" - #-(and mips (not dec)) "-DUNIXCONN" - #+(and lucid pa) "-DHPUX -DHPUX7.0" - ))) - (format t ";;; cc~{ ~A~}~%" args) - (unless - (zerop - #+lucid - (multiple-value-bind (iostream estream exitstatus pid) - ;; in 2.0, run-program is exported from system: - ;; in 3.0, run-program is exported from lcl: - ;; system inheirits lcl - (system::run-program "cc" :arguments args) - (declare (ignore iostream estream pid)) - exitstatus) - #+(or kcl ibcl) - (system (format nil "cc~{ ~A~}" args))) - (error "Compile of ~A failed." src))))) + (let ((source (merge-pathnames filename source-path)) + (binary (merge-pathnames filename binary-path))) + ;; If the source and binary pathnames are the same, + ;; then don't supply an output file just to be sure + ;; compile-file defaults correctly. + #+(or kcl ibcl) (load source) + (if (equal source binary) + (compile-file source) + (compile-file source :output-file binary)) + binary)) + (compile-and-load (filename) + (load (compile-lisp filename))) + #+(or lucid kcl ibcl) + (compile-c (filename) + (let* ((c-filename (concatenate 'string filename ".c")) + (o-filename (concatenate 'string filename ".o")) + (src (merge-pathnames c-filename source-path)) + (obj (merge-pathnames o-filename binary-path)) + (args (list "-c" (namestring src) + "-o" (namestring obj) + #+mips "-G 0" + #+(or hp sysv) "-DSYSV" + #+(and mips (not dec)) "-I/usr/include/bsd" + #-(and mips (not dec)) "-DUNIXCONN" + #+(and lucid pa) "-DHPUX -DHPUX7.0" + ))) + (format t ";;; cc~{ ~A~}~%" args) + (unless + (zerop + #+lucid + (multiple-value-bind (iostream estream exitstatus pid) + ;; in 2.0, run-program is exported from system: + ;; in 3.0, run-program is exported from lcl: + ;; system inheirits lcl + (system::run-program "cc" :arguments args) + (declare (ignore iostream estream pid)) + exitstatus) + #+(or kcl ibcl) + (system (format nil "cc~{ ~A~}" args))) + (error "Compile of ~A failed." src))))) ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. @@ -458,9 +458,9 @@ (compile-and-load "depdefs") (compile-and-load "clx") (compile-and-load "dependent") - #+excl (compile-and-load "exclcmac") ; these are just macros - (compile-and-load "macros") ; these are just macros - (compile-and-load "bufmac") ; these are just macros + #+excl (compile-and-load "exclcmac") ; these are just macros + (compile-and-load "macros") ; these are just macros + (compile-and-load "bufmac") ; these are just macros (compile-and-load "buffer") (compile-and-load "display") (compile-and-load "gcontext") @@ -487,35 +487,35 @@ ;;; You should have a module definition somewhere so the require/provide ;;; mechanism can avoid reloading CLX. In an ideal world, somebody would ;;; just put -;;; (REQUIRE 'CLX) +;;; (REQUIRE 'CLX) ;;; in their file (some implementations don't have a central registry for ;;; modules, so a pathname needs to be supplied). ;;; The REQUIRE should find a file that does -;;; (IN-PACKAGE 'XLIB :USE '(LISP)) -;;; (PROVIDE 'CLX) -;;; (LOAD ) -;;; (LOAD-CLX ) +;;; (IN-PACKAGE 'XLIB :USE '(LISP)) +;;; (PROVIDE 'CLX) +;;; (LOAD ) +;;; (LOAD-CLX ) #-(or lispm allegro Minima) (defun load-clx (&optional (binary-pathname-defaults "") - &key (macrosp nil)) + &key (macrosp nil)) (let* ((source-path (pathname "")) - (path (make-pathname - :host (pathname-host source-path) - :device (pathname-device source-path) - :directory (pathname-directory source-path) - :name (pathname-name source-path) - :type nil - :version (pathname-version source-path))) - (binary-path (merge-pathnames binary-pathname-defaults - path)) - (*load-verbose* t)) + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path)) + (*load-verbose* t)) (flet ((load-binary (filename) - (let ((binary (merge-pathnames filename binary-path))) - (load binary)))) + (let ((binary (merge-pathnames filename binary-path))) + (load binary)))) (load-binary "package") #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) @@ -524,9 +524,9 @@ (load-binary "clx") (load-binary "dependent") (when macrosp - #+excl (load-binary "exclcmac") - (load-binary "macros") - (load-binary "bufmac")) + #+excl (load-binary "exclcmac") + (load-binary "macros") + (load-binary "bufmac")) (load-binary "buffer") (load-binary "display") (load-binary "gcontext") @@ -555,13 +555,13 @@ #+(or) ;ecl (flet ((compile-if-old (destdir sources &rest options) - (mapcar #'(lambda (source) - (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) - (unless (and (probe-file object) - (>= (file-write-date object) (file-write-date source))) - (apply #'compile-file source :output-file object options)) - object)) - sources))) + (mapcar #'(lambda (source) + (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) + (unless (and (probe-file object) + (>= (file-write-date object) (file-write-date source))) + (apply #'compile-file source :output-file object options)) + object)) + sources))) (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t))) (c::build-fasl "clx" :lisp-files clx-objects))) diff --git a/src/clx/demo/bezier.lisp b/src/clx/demo/bezier.lisp index fca439b00..b226a373c 100644 --- a/src/clx/demo/bezier.lisp +++ b/src/clx/demo/bezier.lisp @@ -3,9 +3,9 @@ ;;; CLX interface for Bezier Spline Extension. ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -28,10 +28,10 @@ ;; Draw Bezier splines on drawable using gcontext. ;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3) (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) + (type gcontext gcontext) + (type sequence points)) (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "bezier"))) + (opcode (extension-opcode display "bezier"))) (with-buffer-request (display opcode :gc-force gcontext) ((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier (drawable drawable) diff --git a/src/clx/demo/beziertest.lisp b/src/clx/demo/beziertest.lisp index a8b2c2feb..2f42fb98d 100644 --- a/src/clx/demo/beziertest.lisp +++ b/src/clx/demo/beziertest.lisp @@ -3,9 +3,9 @@ ;;; CLX Bezier Spline Extension demo program ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -23,59 +23,59 @@ (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) ;; Display the part picture in /extensions/test/datafile (let* ((display (open-display host)) - (width 800) - (height 800) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white)) - (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) - (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) + (width 800) + (height 800) + (screen (display-default-screen display)) + (black (screen-black-pixel screen)) + (white (screen-white-pixel screen)) + (win (create-window + :parent (screen-root screen) + :background black + :border white + :border-width 1 + :colormap (screen-default-colormap screen) + :bit-gravity :center + :event-mask '(:exposure :key-press) + :x 20 :y 20 + :width width :height height)) + (gc (create-gcontext + :drawable win + :background black + :foreground white)) + (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) + (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) ;; Read the data (with-open-file (stream pathname) (loop - (case (read-char stream nil :eof) - (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) - (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) - ((#\space #\newline #\tab)) - (otherwise (return))))) + (case (read-char stream nil :eof) + (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) + (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) + ((#\space #\newline #\tab)) + (otherwise (return))))) ;; The data points were created to fit in a 2048x2048 square, ;; this means scale_factor will always be small enough so that ;; we don't need to worry about overflows. (let ((factor (ash (min width height) 5))) (dotimes (i (length lines)) - (setf (aref lines i) - (ash (* (aref lines i) factor) -16))) + (setf (aref lines i) + (ash (* (aref lines i) factor) -16))) (dotimes (i (length curves)) - (setf (aref curves i) - (ash (* (aref curves i) factor) -16)))) + (setf (aref curves i) + (ash (* (aref curves i) factor) -16)))) - (map-window win) ; Map the window + (map-window win) ; Map the window ;; Handle events (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - (draw-segments win gc lines) - (draw-curves win gc curves) - (draw-glyphs win gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from bezier-test t)))) + (loop + (event-case (display :force-output-p t) + (exposure ;; Come here on exposure events + (window count) + (when (zerop count) ;; Ignore all but the last exposure event + (clear-area window) + (draw-segments win gc lines) + (draw-curves win gc curves) + (draw-glyphs win gc 10 10 "Press any key to exit") + ;; Returning non-nil causes event-case to exit + t)) + (key-press () (return-from bezier-test t)))) (close-display display)))) diff --git a/src/clx/demo/clclock.lisp b/src/clx/demo/clclock.lisp index 1b36864a2..7f3ef9280 100644 --- a/src/clx/demo/clclock.lisp +++ b/src/clx/demo/clclock.lisp @@ -21,27 +21,27 @@ :width (+ 20 width) :height (+ 20 ascent) :background (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue"))))) + (xlib:lookup-color *colormap* + "midnightblue"))))) (defvar *gcontext* (xlib:create-gcontext :drawable *win* - :fill-style :solid + :fill-style :solid :background (xlib:screen-white-pixel *screen*) :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color - *colormap* - "yellow")) - :font *font*)) + (xlib:lookup-color + *colormap* + "yellow")) + :font *font*)) (defvar *background* (xlib:create-gcontext - :drawable *win* - :fill-style :solid - :background (xlib:screen-white-pixel *screen*) - :foreground (xlib:alloc-color *colormap* - (xlib:lookup-color *colormap* - "midnightblue")) - :font *font*)) + :drawable *win* + :fill-style :solid + :background (xlib:screen-white-pixel *screen*) + :foreground (xlib:alloc-color *colormap* + (xlib:lookup-color *colormap* + "midnightblue")) + :font *font*)) (defvar *palette* nil) (defvar *black* (xlib:screen-black-pixel *screen*)) @@ -58,17 +58,17 @@ (let ((string (clock-string))) (let ((string-width (xlib:text-width *gcontext* string))) (xlib:draw-rectangle *win* *background* - 0 0 - (xlib:drawable-width *win*) - (xlib:drawable-height *win*) - :fill-p) + 0 0 + (xlib:drawable-width *win*) + (xlib:drawable-height *win*) + :fill-p) (xlib:draw-glyphs *win* *gcontext* - (- (truncate - (- (xlib:drawable-width *win*) string-width) - 2) - 10) - (- (xlib:drawable-height *win*) 10) - string))) + (- (truncate + (- (xlib:drawable-width *win*) string-width) + 2) + 10) + (- (xlib:drawable-height *win*) 10) + string))) (xlib:display-force-output *display*)) (defun clock () diff --git a/src/clx/demo/clipboard.lisp b/src/clx/demo/clipboard.lisp index dd45a3168..5c0e03d92 100644 --- a/src/clx/demo/clipboard.lisp +++ b/src/clx/demo/clipboard.lisp @@ -114,55 +114,55 @@ (defun send-copy (selection target property requestor time) (flet ((send (target property) - (case target - ((:string) - (format t "~&> sending text data~%") (finish-output) - (change-property requestor property - "Hello, World (from the CLX clipboard)!" - target 8 - :transform #'char-code) - property) - (:targets - (format t "~&> sending targets list~%") (finish-output) - ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. - (let ((targets - (mapcar (lambda (x) (intern-atom *display* x)) - '(:targets :timestamp :multiple :string)))) - (change-property requestor property targets target 32)) - property) - (:timestamp - (format t "~&> sending timestamp~%") (finish-output) - (change-property requestor property (list *time*) target 32) - property) - (t - (format t "~&> sending none~%") (finish-output) - nil)))) + (case target + ((:string) + (format t "~&> sending text data~%") (finish-output) + (change-property requestor property + "Hello, World (from the CLX clipboard)!" + target 8 + :transform #'char-code) + property) + (:targets + (format t "~&> sending targets list~%") (finish-output) + ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. + (let ((targets + (mapcar (lambda (x) (intern-atom *display* x)) + '(:targets :timestamp :multiple :string)))) + (change-property requestor property targets target 32)) + property) + (:timestamp + (format t "~&> sending timestamp~%") (finish-output) + (change-property requestor property (list *time*) target 32) + property) + (t + (format t "~&> sending none~%") (finish-output) + nil)))) (case target ;; WARNING: this is untested. I don't know of any clients which ;; use the :MULTIPLE target. (:multiple (let* ((list (get-property requestor property)) - (plist (mapcar (lambda (x) (atom-name *display* x)) list))) - (loop for (ptarget pproperty) on plist by #'cddr - with all-succeeded = t - if (send ptarget pproperty) - collect ptarget into result - and collect pproperty into result - else - collect nil into result - and collect pproperty into result - and do (setf all-succeeded nil) - finally (unless all-succeeded - (let ((new-list - (mapcar (lambda (x) (intern-atom *display* x)) - result))) - (change-property requestor property new-list - target 32)))))) + (plist (mapcar (lambda (x) (atom-name *display* x)) list))) + (loop for (ptarget pproperty) on plist by #'cddr + with all-succeeded = t + if (send ptarget pproperty) + collect ptarget into result + and collect pproperty into result + else + collect nil into result + and collect pproperty into result + and do (setf all-succeeded nil) + finally (unless all-succeeded + (let ((new-list + (mapcar (lambda (x) (intern-atom *display* x)) + result))) + (change-property requestor property new-list + target 32)))))) (t (setf property (send target property)))) (send-event requestor :selection-notify (make-event-mask) - :selection selection :target target - :property property :time time - :event-window requestor :window requestor))) + :selection selection :target target + :property property :time time + :event-window requestor :window requestor))) (defun main () (let* ((*display* (open-default-display)) diff --git a/src/clx/demo/clx-demos.lisp b/src/clx/demo/clx-demos.lisp index 06c4fa36d..20d1bc96d 100644 --- a/src/clx/demo/clx-demos.lisp +++ b/src/clx/demo/clx-demos.lisp @@ -34,38 +34,38 @@ (defun ,fun-name ,args ,doc (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) + #+:cmu + (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) + #+(or sbcl allegro clisp) + (progn + (setf *display* (xlib::open-default-display)) + (setf *screen* (xlib:display-default-screen *display*))) + #-(or cmu sbcl allegro clisp) + (progn + ;; Portable method + (setf *display* (xlib:open-display (machine-instance))) + (setf *screen* (xlib:display-default-screen *display*))) + (setf *root* (xlib:screen-root *screen*)) + (setf *black-pixel* (xlib:screen-black-pixel *screen*)) + (setf *white-pixel* (xlib:screen-white-pixel *screen*))) (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) - (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) + :x ,x :y ,y + :event-mask nil + :width ,width :height ,height + :background *white-pixel* + :border *black-pixel* + :border-width 2 + :override-redirect :on))) + (xlib:map-window *window*) + ;; + ;; I hate to do this since this is not something any normal + ;; program should do ... + (setf (xlib:window-priority *window*) :above) + (xlib:display-finish-output *display*) + (unwind-protect + (progn ,@forms) + (xlib:unmap-window *window*) + (xlib:display-finish-output *display*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) (export ',fun-name) @@ -93,45 +93,45 @@ (defun demo () (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) + `(let ((*package* *keyword-package*)) + (read)))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) - *keyword-package*) - *name-to-function*) - d)) + *keyword-package*) + *name-to-function*) + d)) (loop (fresh-line) (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) + (write-string " ") + (write-line (get d 'demo-name))) (write-string " ") (write-line "Help ") (write-string " ") (write-line "Quit") (write-string "Enter demo name: ") (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) + (case demo + (:help + (let* ((demo (read-demo)) + (fun (gethash demo *name-to-function*))) + (fresh-line) + (if fun + (format t "~&~%~A~&~%" (get fun 'demo-doc)) + (format t "Unknown demo name -- ~A." demo)))) + (:quit (return t)) + (t + (let ((fun (gethash demo *name-to-function*))) + (if fun + #+mp + (mp:make-process #'(lambda () + (loop + (funcall fun) + (sleep 2))) + :name (format nil "~S" demo)) + #-mp + (funcall fun) + (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) ;;;; Shared demo utilities. @@ -139,8 +139,8 @@ (defun full-window-state (w) (xlib:with-state (w) (values (xlib:drawable-width w) (xlib:drawable-height w) - (xlib:drawable-x w) (xlib:drawable-y w) - (xlib:window-map-state w)))) + (xlib:drawable-x w) (xlib:drawable-y w) + (xlib:window-map-state w)))) ;;;; Greynetic. @@ -150,25 +150,25 @@ ;;; (defun greynetic (window duration) (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) + :drawable window)) + (gcontext (xlib:create-gcontext :drawable window + :background *white-pixel* + :foreground *black-pixel* + :tile pixmap + :fill-style :tiled))) (multiple-value-bind (width height) (full-window-state window) (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) + (let* ((pixmap-data (greynetic-pixmapper)) + (image (xlib:create-image :width 32 :height 32 + :depth 1 :data pixmap-data))) + (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) + (xlib:draw-rectangle window gcontext + (- (random width) 5) + (- (random height) 5) + (+ 4 (random (truncate width 3))) + (+ 4 (random (truncate height 3))) + t)) + (xlib:display-force-output *display*))) (xlib:free-gcontext gcontext) (xlib:free-pixmap pixmap))) @@ -180,20 +180,20 @@ (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref pixmap-data i j) bit + (aref pixmap-data (+ 4 i) j) bit + (aref pixmap-data (+ 8 i) j) bit + (aref pixmap-data (+ 12 i) j) bit + (aref pixmap-data (+ 16 i) j) bit + (aref pixmap-data (+ 20 i) j) bit + (aref pixmap-data (+ 24 i) j) bit + (aref pixmap-data (+ 28 i) j) bit))))) pixmap-data)) #+nil @@ -232,74 +232,74 @@ (xlib:clear-area window) (xlib:display-force-output *display*) (do ((h histories (cdr h)) - (l lengths (cdr l))) - ((null h)) - (do ((x (qix-buffer (car h)) (cdr x)) - (i 0 (1+ i))) - ((= i (car l))) - (rplaca x (make-array 4)))) + (l lengths (cdr l))) + ((null h)) + (do ((x (qix-buffer (car h)) (cdr x)) + (i 0 (1+ i))) + ((= i (car l))) + (rplaca x (make-array 4)))) ;; Start each qix at a random spot on the screen. (dolist (h histories) - (let ((x (random width)) - (y (random height))) - (rplaca (qix-buffer h) - (make-array 4 :initial-contents (list x y x y))))) + (let ((x (random width)) + (y (random height))) + (rplaca (qix-buffer h) + (make-array 4 :initial-contents (list x y x y))))) (rplacd (last histories) histories) (let ((x1 0) (y1 0) (x2 0) (y2 0) - (dx1 0) (dy1 0) (dx2 0) (dy2 0) - tem line next-line qix - (gc (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :line-width 0 :line-style :solid - :function boole-c2))) - (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) - (dotimes (i duration) - ;; Line is the next line in the next qix. Rotate this qix and - ;; the qix ring. - (setq qix (car histories)) - (setq line (car (qix-buffer qix))) - (setq next-line (cadr (qix-buffer qix))) - (setf (qix-buffer qix) (cdr (qix-buffer qix))) - (setq histories (cdr histories)) - (setf x1 (svref line 0)) - (setf y1 (svref line 1)) - (setf x2 (svref line 2)) - (setf y2 (svref line 3)) - (xlib:draw-line window gc x1 y1 x2 y2) - (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) - (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) - (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) - (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) - (cond ((> dx1 10) (setq dx1 10)) - ((< dx1 -10) (setq dx1 -10))) - (cond ((> dy1 10) (setq dy1 10)) - ((< dy1 -10) (setq dy1 -10))) - (cond ((> dx2 10) (setq dx2 10)) - ((< dx2 -10) (setq dx2 -10))) - (cond ((> dy2 10) (setq dy2 10)) - ((< dy2 -10) (setq dy2 -10))) - (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) - (setq dx1 (- dx1)))) - (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) - (setq dx2 (- dx2)))) - (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) - (setq dy1 (- dy1)))) - (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) - (setq dy2 (- dy2)))) - (setf (qix-dy2 qix) dy2) - (setf (qix-dx2 qix) dx2) - (setf (qix-dy1 qix) dy1) - (setf (qix-dx1 qix) dx1) -` (when (svref next-line 0) - (xlib:draw-line window gc - (svref next-line 0) (svref next-line 1) - (svref next-line 2) (svref next-line 3))) - (setf (svref next-line 0) (+ x1 dx1)) - (setf (svref next-line 1) (+ y1 dy1)) - (setf (svref next-line 2) (+ x2 dx2)) - (setf (svref next-line 3) (+ y2 dy2)) - (xlib:display-force-output *display*)))))) + (dx1 0) (dy1 0) (dx2 0) (dy2 0) + tem line next-line qix + (gc (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :line-width 0 :line-style :solid + :function boole-c2))) + (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) + (dotimes (i duration) + ;; Line is the next line in the next qix. Rotate this qix and + ;; the qix ring. + (setq qix (car histories)) + (setq line (car (qix-buffer qix))) + (setq next-line (cadr (qix-buffer qix))) + (setf (qix-buffer qix) (cdr (qix-buffer qix))) + (setq histories (cdr histories)) + (setf x1 (svref line 0)) + (setf y1 (svref line 1)) + (setf x2 (svref line 2)) + (setf y2 (svref line 3)) + (xlib:draw-line window gc x1 y1 x2 y2) + (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) + (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) + (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) + (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) + (cond ((> dx1 10) (setq dx1 10)) + ((< dx1 -10) (setq dx1 -10))) + (cond ((> dy1 10) (setq dy1 10)) + ((< dy1 -10) (setq dy1 -10))) + (cond ((> dx2 10) (setq dx2 10)) + ((< dx2 -10) (setq dx2 -10))) + (cond ((> dy2 10) (setq dy2 10)) + ((< dy2 -10) (setq dy2 -10))) + (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) + (setq dx1 (- dx1)))) + (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) + (setq dx2 (- dx2)))) + (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) + (setq dy1 (- dy1)))) + (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) + (setq dy2 (- dy2)))) + (setf (qix-dy2 qix) dy2) + (setf (qix-dx2 qix) dx2) + (setf (qix-dy1 qix) dy1) + (setf (qix-dx1 qix) dx1) +` (when (svref next-line 0) + (xlib:draw-line window gc + (svref next-line 0) (svref next-line 1) + (svref next-line 2) (svref next-line 3))) + (setf (svref next-line 0) (+ x1 dx1)) + (setf (svref next-line 1) (+ y1 dy1)) + (setf (svref next-line 2) (+ x2 dx2)) + (setf (svref next-line 3) (+ y2 dy2)) + (xlib:display-force-output *display*)))))) (defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) @@ -338,29 +338,29 @@ (defmacro psin (val) `(let* ((val ,val) - neg - frac - sinlo) + neg + frac + sinlo) (if (>= val d180) - (setq neg t - val (- val d180))) + (setq neg t + val (- val d180))) (if (>= val d90) - (setq val (- d180 val))) + (setq val (- d180 val))) (setq frac (logand val 7)) (setq val (ash val -3)) ;; (setq sinlo (if (>= val 90) - (svref sin-array 90) - (svref sin-array val))) + (svref sin-array 90) + (svref sin-array val))) ;; (if (< val 90) - (setq sinlo - (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) - -3)))) + (setq sinlo + (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) + -3)))) ;; (if neg - (- sinlo) - sinlo))) + (- sinlo) + sinlo))) (defmacro pcos (x) `(let ((tmp (- ,x d270))) @@ -371,24 +371,24 @@ (defmacro high-16bits-* (a b) `(let ((a-h (ash ,a -8)) - (b-h (ash ,b -8))) + (b-h (ash ,b -8))) (+ (* a-h b-h) - (ash (* a-h (logand ,b 255)) -8) - (ash (* b-h (logand ,a 255)) -8)))) + (ash (* a-h (logand ,b 255)) -8) + (ash (* b-h (logand ,a 255)) -8)))) (defun complete (style petal) (let ((repnum 1) - factor cntval needed) + factor cntval needed) (dotimes (i 3) (case i - (0 (setq factor 2 cntval 6)) - (1 (setq factor 3 cntval 2)) - (2 (setq factor 5 cntval 1))) + (0 (setq factor 2 cntval 6)) + (1 (setq factor 3 cntval 2)) + (2 (setq factor 5 cntval 1))) (do () - ((or (minusp cntval) (not (zerop (rem style factor))))) - (setq repnum (* repnum factor)) - (setq cntval (1- cntval)) - (setq style (floor style factor)))) + ((or (minusp cntval) (not (zerop (rem style factor))))) + (setq repnum (* repnum factor)) + (setq cntval (1- cntval)) + (setq style (floor style factor)))) (setq needed (floor vecmax repnum)) (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) @@ -402,57 +402,57 @@ (defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) (let ((width 512) - (height 512)) + (height 512)) (xlib:clear-area petal-window) (xlib:display-force-output *display*) (let ((veccnt 0) - (nustyle 722) - (nupetal 3) - (scalfac (1+ (floor scalfac-fac (min width height)))) - (ctrx (floor width 2)) - (ctry (floor height 2)) - (tt 0) - (s 0) - (lststyle 0) - (lstpetal 0) - (petstyle 0) - (vectors 0) - (r 0) - (x1 0) - (y1 0) - (x2 0) - (y2 0) - (i 0) - (gc (xlib:create-gcontext :drawable petal-window - :foreground *black-pixel* - :background *white-pixel* - :line-width 0 :line-style :solid))) + (nustyle 722) + (nupetal 3) + (scalfac (1+ (floor scalfac-fac (min width height)))) + (ctrx (floor width 2)) + (ctry (floor height 2)) + (tt 0) + (s 0) + (lststyle 0) + (lstpetal 0) + (petstyle 0) + (vectors 0) + (r 0) + (x1 0) + (y1 0) + (x2 0) + (y2 0) + (i 0) + (gc (xlib:create-gcontext :drawable petal-window + :foreground *black-pixel* + :background *white-pixel* + :line-width 0 :line-style :solid))) (loop - (when (zerop veccnt) - (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal - style nustyle petstyle (rem (* petal style) d360) - vectors (complete style petal)) - (when continuous - (setq nupetal (+ nupetal petinc) - nustyle (+ nustyle styinc))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (xlib:clear-area petal-window) - (xlib:display-force-output *display*))) - (when (or (/= lststyle style) (/= lstpetal petal)) - (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 - tt (rem (+ tt style) d360) - s (rem (+ s petstyle) d360) - r (pcos s)) - (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) - y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) - (when (/= i 1) - (xlib:draw-line petal-window gc x1 y1 x2 y2) - (xlib:display-force-output *display*))) - (when (> veccnt vectors) - (setq veccnt 0) - (setq how-many (1- how-many)) - (sleep 2) - (when (zerop how-many) (return))))))) + (when (zerop veccnt) + (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal + style nustyle petstyle (rem (* petal style) d360) + vectors (complete style petal)) + (when continuous + (setq nupetal (+ nupetal petinc) + nustyle (+ nustyle styinc))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (xlib:clear-area petal-window) + (xlib:display-force-output *display*))) + (when (or (/= lststyle style) (/= lstpetal petal)) + (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 + tt (rem (+ tt style) d360) + s (rem (+ s petstyle) d360) + r (pcos s)) + (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) + y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) + (when (/= i 1) + (xlib:draw-line petal-window gc x1 y1 x2 y2) + (xlib:display-force-output *display*))) + (when (> veccnt vectors) + (setq veccnt 0) + (setq how-many (1- how-many)) + (sleep 2) + (when (zerop how-many) (return))))))) (defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) 100 100 512 512 @@ -508,7 +508,7 @@ ;;; (defmacro invert-rectangle (x y height width) `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* - ,x ,y ,width ,height t)) + ,x ,y ,width ,height t)) (defmacro update-screen () `(xlib:display-force-output *display*)) @@ -522,17 +522,17 @@ (defun slide-up (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) - (truncate (- start-y end-y) *vertical-velocity*) + (truncate (- start-y end-y) *vertical-velocity*) (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (- old-y *vertical-velocity*)) - (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (- old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) + (width (* disk-size 2)) + (old-y start-y (- old-y *vertical-velocity*)) + (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (- old-y pixels-left) disk-thickness width) + (invert-rectangle x old-y disk-thickness width) + (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle x old-y disk-thickness width) (invert-rectangle x new-y disk-thickness width) @@ -544,17 +544,17 @@ (defun slide-down (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) - (truncate (- end-y start-y) *vertical-velocity*) + (truncate (- end-y start-y) *vertical-velocity*) (do ((x (- x disk-size)) - (width (* disk-size 2)) - (old-y start-y (+ old-y *vertical-velocity*)) - (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle x (+ old-y pixels-left) disk-thickness width) - (invert-rectangle x old-y disk-thickness width) - (update-screen))) + (width (* disk-size 2)) + (old-y start-y (+ old-y *vertical-velocity*)) + (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle x (+ old-y pixels-left) disk-thickness width) + (invert-rectangle x old-y disk-thickness width) + (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle X old-y disk-thickness width) (invert-rectangle X new-y disk-thickness width) @@ -569,11 +569,11 @@ (defun lift-disk (needle) "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." (let* ((height (needle-top-height needle)) - (disk (pop (needle-disk-stack needle)))) + (disk (pop (needle-disk-stack needle)))) (slide-up height - *transfer-height* - (needle-position needle) - (disk-size disk)) + *transfer-height* + (needle-position needle) + (disk-size disk)) disk)) ;;; Drop-disk drops a disk positioned over needle at the transfer height @@ -583,9 +583,9 @@ "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (push disk (needle-disk-stack needle)) (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) + (needle-top-height needle) + (needle-position needle) + (disk-size disk)) t) @@ -595,13 +595,13 @@ (defun drop-initial-disk (disk needle) "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (let* ((size (disk-size disk)) - (lx (- (needle-position needle) size))) + (lx (- (needle-position needle) size))) (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) (push disk (needle-disk-stack needle)) (slide-down *transfer-height* - (needle-top-height needle) - (needle-position needle) - (disk-size disk)) + (needle-top-height needle) + (needle-position needle) + (disk-size disk)) t)) @@ -613,15 +613,15 @@ (defun slide-right (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) - (truncate (- end-x start-x) *horizontal-velocity*) + (truncate (- end-x start-x) *horizontal-velocity*) (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) - (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (invert-rectangle left-x Y disk-thickness pixels-left) - (update-screen))) + (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (invert-rectangle right-x Y disk-thickness pixels-left) + (invert-rectangle left-x Y disk-thickness pixels-left) + (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to right ;; side of disk, then chops off left side. (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) @@ -633,19 +633,19 @@ (defun slide-left (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) - (truncate (- start-x end-x) *horizontal-velocity*) + (truncate (- start-x end-x) *horizontal-velocity*) (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) - (- right-x *horizontal-velocity*)) - (left-x (- (- start-x disk-size) *horizontal-velocity*) - (- left-x *horizontal-velocity*)) - (number-moves number-moves (1- number-moves))) - ((zerop number-moves) - (when (plusp pixels-left) - (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) - (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) - (invert-rectangle left-x Y disk-thickness pixels-left) - (invert-rectangle right-x Y disk-thickness pixels-left) - (update-screen))) + (- right-x *horizontal-velocity*)) + (left-x (- (- start-x disk-size) *horizontal-velocity*) + (- left-x *horizontal-velocity*)) + (number-moves number-moves (1- number-moves))) + ((zerop number-moves) + (when (plusp pixels-left) + (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) + (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) + (invert-rectangle left-x Y disk-thickness pixels-left) + (invert-rectangle right-x Y disk-thickness pixels-left) + (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to left ;; side of disk, then chops off right side. (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) @@ -662,10 +662,10 @@ (defun transfer-disk (disk start-needle end-needle) "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." (let ((start (needle-position start-needle)) - (end (needle-position end-needle))) + (end (needle-position end-needle))) (if (< start end) - (slide-right start end *transfer-height* (disk-size disk)) - (slide-left start end *transfer-height* (disk-size disk))) + (slide-right start end *transfer-height* (disk-size disk)) + (slide-left start end *transfer-height* (disk-size disk))) disk)) @@ -674,9 +674,9 @@ (defun move-one-disk (start-needle end-needle) "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." (drop-disk (transfer-disk (lift-disk start-needle) - start-needle - end-needle) - end-needle) + start-needle + end-needle) + end-needle) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE @@ -687,11 +687,11 @@ "Moves the top N disks from START-NEEDLE to END-NEEDLE. Uses TEMP-NEEDLE for temporary storage." (cond ((= n 1) - (move-one-disk start-needle end-needle)) - (t - (move-n-disks (1- n) start-needle temp-needle end-needle) - (move-one-disk start-needle end-needle) - (move-n-disks (1- n) temp-needle end-needle start-needle))) + (move-one-disk start-needle end-needle)) + (t + (move-n-disks (1- n) start-needle temp-needle end-needle) + (move-one-disk start-needle end-needle) + (move-n-disks (1- n) temp-needle end-needle start-needle))) t) @@ -701,27 +701,27 @@ (multiple-value-bind (width height) (full-window-state window) (declare (ignore width)) (let* ((*hanoi-window* window) - (*hanoi-window-height* height) - (*transfer-height* (- height (* disk-spacing n))) - (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* - :foreground *white-pixel* - :background *black-pixel* - :fill-style :solid - :function boole-c2))) + (*hanoi-window-height* height) + (*transfer-height* (- height (* disk-spacing n))) + (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* + :foreground *white-pixel* + :background *black-pixel* + :fill-style :solid + :function boole-c2))) (xlib:clear-area *hanoi-window*) (xlib:display-force-output *display*) (let ((needle-1 (make-needle :position 184)) - (needle-2 (make-needle :position 382)) - (needle-3 (make-needle :position 584))) - (setf (needle-disk-stack needle-1) ()) - (setf (needle-disk-stack needle-2) ()) - (setf (needle-disk-stack needle-3) ()) - (do ((n n (1- n)) - (available-disks available-disks (cdr available-disks))) - ((zerop n)) - (drop-initial-disk (car available-disks) needle-1)) - (move-n-disks n needle-1 needle-3 needle-2) - t)))) + (needle-2 (make-needle :position 382)) + (needle-3 (make-needle :position 584))) + (setf (needle-disk-stack needle-1) ()) + (setf (needle-disk-stack needle-2) ()) + (setf (needle-disk-stack needle-3) ()) + (do ((n n (1- n)) + (available-disks available-disks (cdr available-disks))) + ((zerop n)) + (drop-initial-disk (car available-disks) needle-1)) + (move-n-disks n needle-1 needle-3 needle-2) + t)))) ;;; Change the names of these when the DEMO loop isn't so stupid. ;;; @@ -729,7 +729,7 @@ 0 100 768 300 "Solves the Towers of Hanoi problem before your very eyes." (let ((*horizontal-velocity* 3) - (*vertical-velocity* 1)) + (*vertical-velocity* 1)) (hanoi *window* how-many))) ;;; (defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) @@ -757,7 +757,7 @@ ;;; velocity since the loop terminates as a function of the y velocity. ;;; (defun bounce-window (window &optional - (x-velocity 0) (elasticity 0.85) (gravity 2)) + (x-velocity 0) (elasticity 0.85) (gravity 2)) (unless (< 0 elasticity 1) (error "Elasticity must be between 0 and 1.")) (unless (plusp gravity) @@ -765,48 +765,48 @@ (multiple-value-bind (width height x y mapped) (full-window-state window) (when (eq mapped :viewable) (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) - (left-of-window-at-right (- (xlib:drawable-width *root*) width)) - (y-velocity 0) - (prev-neg-velocity most-negative-fixnum) - (number-problems nil)) - (declare (fixnum top-of-window-at-bottom left-of-window-at-right - y-velocity)) - (loop - (when (= prev-neg-velocity 0) (return t)) - (let ((negative-velocity (minusp y-velocity))) - (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) - (when (and negative-velocity (>= y-velocity 0)) - (setf negative-velocity nil)) - (let ((next-x (+ x x-velocity))) - (declare (fixnum next-x)) - (when (or (> next-x left-of-window-at-right) - (< next-x 0)) - (setq x-velocity (- (truncate (* elasticity x-velocity))))) - (setq x next-x)) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*)))))))) + (left-of-window-at-right (- (xlib:drawable-width *root*) width)) + (y-velocity 0) + (prev-neg-velocity most-negative-fixnum) + (number-problems nil)) + (declare (fixnum top-of-window-at-bottom left-of-window-at-right + y-velocity)) + (loop + (when (= prev-neg-velocity 0) (return t)) + (let ((negative-velocity (minusp y-velocity))) + (loop + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y)) + (when (and negative-velocity (>= y-velocity 0)) + (setf negative-velocity nil)) + (let ((next-x (+ x x-velocity))) + (declare (fixnum next-x)) + (when (or (> next-x left-of-window-at-right) + (< next-x 0)) + (setq x-velocity (- (truncate (* elasticity x-velocity))))) + (setq x next-x)) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*)))))))) ;;; Change the name of this when DEMO is not so stupid. ;;; @@ -841,8 +841,8 @@ (defun recurrence (display window &optional (point-count 10000)) (let ((gc (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel*))) + :background *white-pixel* + :foreground *black-pixel*))) (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) @@ -889,38 +889,38 @@ (defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) (let ((gcontext (xlib:create-gcontext :drawable window - :function boole-c2 - :plane-mask (logxor *white-pixel* - *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* - :fill-style :solid)) - (rectangles (make-array (* 4 num-rectangles) - :element-type 'number - :initial-element 0))) + :function boole-c2 + :plane-mask (logxor *white-pixel* + *black-pixel*) + :background *white-pixel* + :foreground *black-pixel* + :fill-style :solid)) + (rectangles (make-array (* 4 num-rectangles) + :element-type 'number + :initial-element 0))) (multiple-value-bind (width height) (full-window-state window) (let ((center-x (ash width -1)) - (center-y (ash height -1)) - (x-dir -2) - (y-dir -2) - (x-off 2) - (y-off 2)) - (dotimes (iter (truncate num-iterations num-rectangles)) - (dotimes (i num-rectangles) - (setf (rect-x rectangles i) (- center-x x-off)) - (setf (rect-y rectangles i) (- center-y y-off)) - (setf (rect-width rectangles i) (ash x-off 1)) - (setf (rect-height rectangles i) (ash y-off 1)) - (incf x-off x-dir) - (incf y-off y-dir) - (when (or (<= x-off 0) (>= x-off center-x)) - (decf x-off (ash x-dir 1)) - (setf x-dir (- x-dir))) - (when (or (<= y-off 0) (>= y-off center-y)) - (decf y-off (ash y-dir 1)) - (setf y-dir (- y-dir)))) - (xlib:draw-rectangles window gcontext rectangles t) - (xlib:display-force-output display)))) + (center-y (ash height -1)) + (x-dir -2) + (y-dir -2) + (x-off 2) + (y-off 2)) + (dotimes (iter (truncate num-iterations num-rectangles)) + (dotimes (i num-rectangles) + (setf (rect-x rectangles i) (- center-x x-off)) + (setf (rect-y rectangles i) (- center-y y-off)) + (setf (rect-width rectangles i) (ash x-off 1)) + (setf (rect-height rectangles i) (ash y-off 1)) + (incf x-off x-dir) + (incf y-off y-dir) + (when (or (<= x-off 0) (>= x-off center-x)) + (decf x-off (ash x-dir 1)) + (setf x-dir (- x-dir))) + (when (or (<= y-off 0) (>= y-off center-y)) + (decf y-off (ash y-dir 1)) + (setf y-dir (- y-dir)))) + (xlib:draw-rectangles window gcontext rectangles t) + (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) (defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) @@ -940,7 +940,7 @@ (defmacro xor-ball (pixmap window gcontext x y) `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) + ,window ,x ,y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) @@ -952,61 +952,61 @@ (x (random (- *max-bball-x* *ball-size-x*))) (y (random (- *max-bball-y* *ball-size-y*))) (dx (if (zerop (random 2)) (random maximum-x-drift) - (- (random maximum-x-drift)))) + (- (random maximum-x-drift)))) (dy 0)) (defun get-bounce-image () "Returns the pixmap to be bounced around the screen." (xlib::bitmap-image #*000000000000000000000000000000000000 - #*000000000000000000000000000000000000 - #*000000000000000000001000000010000000 - #*000000000000000000000000000100000000 - #*000000000000000000000100001000000000 - #*000000000000000010000000010000000000 - #*000000000000000000100010000000000000 - #*000000000000000000001000000000000000 - #*000000000001111100000000000101010000 - #*000000000010000011000111000000000000 - #*000000000100000000111000000000000000 - #*000000000100000000000000000100000000 - #*000000000100000000001000100010000000 - #*000000111111100000010000000001000000 - #*000000111111100000100000100000100000 - #*000011111111111000000000000000000000 - #*001111111111111110000000100000000000 - #*001111111111111110000000000000000000 - #*011111111111111111000000000000000000 - #*011111111111111111000000000000000000 - #*111111111111110111100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111101100000000000000000 - #*111111111111111111100000000000000000 - #*111111111111110111100000000000000000 - #*011111111111111111000000000000000000 - #*011111111111011111000000000000000000 - #*001111111111111110000000000000000000 - #*001111111111111110000000000000000000 - #*000011111111111000000000000000000000 - #*000000111111100000000000000000000000 - #*000000000000000000000000000000000000)) + #*000000000000000000000000000000000000 + #*000000000000000000001000000010000000 + #*000000000000000000000000000100000000 + #*000000000000000000000100001000000000 + #*000000000000000010000000010000000000 + #*000000000000000000100010000000000000 + #*000000000000000000001000000000000000 + #*000000000001111100000000000101010000 + #*000000000010000011000111000000000000 + #*000000000100000000111000000000000000 + #*000000000100000000000000000100000000 + #*000000000100000000001000100010000000 + #*000000111111100000010000000001000000 + #*000000111111100000100000100000100000 + #*000011111111111000000000000000000000 + #*001111111111111110000000100000000000 + #*001111111111111110000000000000000000 + #*011111111111111111000000000000000000 + #*011111111111111111000000000000000000 + #*111111111111110111100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111101100000000000000000 + #*111111111111111111100000000000000000 + #*111111111111110111100000000000000000 + #*011111111111111111000000000000000000 + #*011111111111011111000000000000000000 + #*001111111111111110000000000000000000 + #*001111111111111110000000000000000000 + #*000011111111111000000000000000000000 + #*000000111111100000000000000000000000 + #*000000000000000000000000000000000000)) (defun bounce-1-ball (pixmap window gcontext ball) (let ((x (ball-x ball)) - (y (ball-y ball)) - (dx (ball-dx ball)) - (dy (ball-dy ball))) + (y (ball-y ball)) + (dx (ball-dx ball)) + (dy (ball-dy ball))) (xor-ball pixmap window gcontext x y) (setq x (+ x dx)) (setq y (+ y dy)) (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) - (setq x (- x dx) - dx (- dx))) + (setq x (- x dx) + dx (- dx))) (if (> y (- *max-bball-y* *ball-size-y*)) - (setq y (- y dy) - dy (- dy))) + (setq y (- y dy) + dy (- dy))) (setq dy (+ dy bball-gravity)) (setf (ball-x ball) x) (setf (ball-y ball) y) @@ -1019,28 +1019,28 @@ (xlib:display-force-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) - (list () (cons (make-ball) list))) - ((= i how-many) list))) - (gcontext (xlib:create-gcontext :drawable window - :foreground *white-pixel* - :background *black-pixel* - :function boole-xor - :exposures :off)) - (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 - :drawable window)) - (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap - :foreground *white-pixel* - :background *black-pixel*))) + (list () (cons (make-ball) list))) + ((= i how-many) list))) + (gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel* + :function boole-xor + :exposures :off)) + (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 + :drawable window)) + (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap + :foreground *white-pixel* + :background *black-pixel*))) (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) - :x 0 :y 0 :width 38 :height 34) + :x 0 :y 0 :width 38 :height 34) (xlib:free-gcontext pixmap-gc) (dolist (ball balls) - (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) + (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) (xlib:display-force-output display) (dotimes (i duration) - (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) + (dolist (ball balls) + (bounce-1-ball bounce-pixmap window gcontext ball)) + (xlib:display-force-output display)) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) diff --git a/src/clx/demo/hello.lisp b/src/clx/demo/hello.lisp index a3fbd88d8..1c3961d1f 100644 --- a/src/clx/demo/hello.lisp +++ b/src/clx/demo/hello.lisp @@ -5,61 +5,61 @@ (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) ;; CLX demo, says STRING using FONT in its own window on HOST (let ((display nil) - (abort t)) + (abort t)) (unwind-protect - (progn - (setq display (open-display host)) - (multiple-value-prog1 - (let* ((screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (font (open-font display font)) - (border 1) ; Minimum margin around the text - (width (+ (text-width font string) (* 2 border))) - (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) - (x (truncate (- (screen-width screen) width) 2)) - (y (truncate (- (screen-height screen) height) 2)) - (window (create-window :parent (screen-root screen) - :x x :y y :width width :height height - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :button-press))) - (gcontext (create-gcontext :drawable window - :background black - :foreground white - :font font))) - ;; Set window manager hints - (set-wm-properties window - :name 'hello-world - :icon-name string - :resource-name string - :resource-class 'hello-world - :command (list* 'hello-world host args) - :x x :y y :width width :height height - :min-width width :min-height height - :input :off :initial-state :normal) - (map-window window) ; Map the window - ;; Handle events - (event-case (display :discard-p t :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (with-state (window) - (let ((x (truncate (- (drawable-width window) width) 2)) - (y (truncate (- (+ (drawable-height window) - (max-char-ascent font)) - (max-char-descent font)) - 2))) - ;; Draw text centered in widnow - (clear-area window) - (draw-glyphs window gcontext x y string))) - ;; Returning non-nil causes event-case to exit - nil)) - (button-press () t))) ;; Pressing any mouse-button exits - (setq abort nil))) + (progn + (setq display (open-display host)) + (multiple-value-prog1 + (let* ((screen (display-default-screen display)) + (black (screen-black-pixel screen)) + (white (screen-white-pixel screen)) + (font (open-font display font)) + (border 1) ; Minimum margin around the text + (width (+ (text-width font string) (* 2 border))) + (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) + (x (truncate (- (screen-width screen) width) 2)) + (y (truncate (- (screen-height screen) height) 2)) + (window (create-window :parent (screen-root screen) + :x x :y y :width width :height height + :background black + :border white + :border-width 1 + :colormap (screen-default-colormap screen) + :bit-gravity :center + :event-mask '(:exposure :button-press))) + (gcontext (create-gcontext :drawable window + :background black + :foreground white + :font font))) + ;; Set window manager hints + (set-wm-properties window + :name 'hello-world + :icon-name string + :resource-name string + :resource-class 'hello-world + :command (list* 'hello-world host args) + :x x :y y :width width :height height + :min-width width :min-height height + :input :off :initial-state :normal) + (map-window window) ; Map the window + ;; Handle events + (event-case (display :discard-p t :force-output-p t) + (exposure ;; Come here on exposure events + (window count) + (when (zerop count) ;; Ignore all but the last exposure event + (with-state (window) + (let ((x (truncate (- (drawable-width window) width) 2)) + (y (truncate (- (+ (drawable-height window) + (max-char-ascent font)) + (max-char-descent font)) + 2))) + ;; Draw text centered in widnow + (clear-area window) + (draw-glyphs window gcontext x y string))) + ;; Returning non-nil causes event-case to exit + nil)) + (button-press () t))) ;; Pressing any mouse-button exits + (setq abort nil))) ;; Ensure display is closed when done (when display - (close-display display :abort abort))))) + (close-display display :abort abort))))) diff --git a/src/clx/demo/mandel.lisp b/src/clx/demo/mandel.lisp index cb4828ec0..5fe3dbc9c 100644 --- a/src/clx/demo/mandel.lisp +++ b/src/clx/demo/mandel.lisp @@ -12,18 +12,18 @@ (defvar *helpwin* nil) (defvar *zoom-table* (make-hash-table)) (defvar *zoomcolmap* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-white-pixel *screen*) - :function boole-xor)) + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-white-pixel *screen*) + :function boole-xor)) (defvar *white* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-white-pixel *screen*) - )) + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-white-pixel *screen*) + )) (defvar *winmap* (make-hash-table)) (defvar *textmap* (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:screen-black-pixel *screen*) - :background (xlib:screen-white-pixel *screen*))) + :drawable (xlib:screen-root *screen*) + :foreground (xlib:screen-black-pixel *screen*) + :background (xlib:screen-white-pixel *screen*))) ;;; OK, this is an ugly hack to make sure we can handle ;;; shift and modstate in a sane way, alas we can't 100% rely @@ -36,9 +36,9 @@ (defun make-shift-foo () (let ((rv 0)) (if (member :shift *modstate*) - (setf rv 1)) + (setf rv 1)) (if (member :character-set-switch *modstate*) - (setf rv (+ rv 2))) + (setf rv (+ rv 2))) rv)) (defstruct (mandel-square (:conc-name ms-)) @@ -65,7 +65,7 @@ (win-list :accessor win-list :initarg :xyzzy-2) (last-window :accessor last-window :initform nil)) (:default-initargs :xyzzy-1 (make-hash-table) - :xyzzy-2 (make-instance 'queue))) + :xyzzy-2 (make-instance 'queue))) (defvar *sysqueue* (make-instance 'out-queue)) @@ -83,9 +83,9 @@ (defmethod empty-p ((q out-queue)) (let ((coll nil)) (maphash #'(lambda (key val) - (declare (ignore key)) - (push (empty-p val) coll)) - (win-queues q)) + (declare (ignore key)) + (push (empty-p val) coll)) + (win-queues q)) (every #'identity coll))) (defmethod empty ((q null)) @@ -95,20 +95,20 @@ (setf (q-tail q) nil)) (defmethod empty ((q out-queue)) (maphash #'(lambda (key val) (declare (ignore key)) (empty val)) - (win-queues q))) + (win-queues q))) (defmethod empty-win ((q out-queue) win) (let ((temp-queue (gethash win (win-queues q)))) (empty temp-queue))) (defmethod enqueue ((q queue) item) (cond ((empty-p q) - (setf (q-head q) (cons item nil)) - (setf (q-tail q) (q-head q))) - (t (setf (cdr (q-tail q)) (cons item nil)) - (setf (q-tail q) (cdr (q-tail q)))))) + (setf (q-head q) (cons item nil)) + (setf (q-tail q) (q-head q))) + (t (setf (cdr (q-tail q)) (cons item nil)) + (setf (q-tail q) (cdr (q-tail q)))))) (defmethod enqueue ((q out-queue) item) (let ((windows (q-head (win-list q))) - (win (ms-win item))) + (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) @@ -116,19 +116,19 @@ (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) - (let ((new (make-queue))) - (setf (gethash win (win-queues q)) new) - (enqueue new item)) - (enqueue temp-queue item))))) + (let ((new (make-queue))) + (setf (gethash win (win-queues q)) new) + (enqueue new item)) + (enqueue temp-queue item))))) (defmethod queue-push ((q queue) item) (cond ((empty-p q) - (setf (q-head q) (cons item nil)) - (setf (q-tail q) (q-head q))) - (t (setf (q-head q) (cons item (q-head q)))))) + (setf (q-head q) (cons item nil)) + (setf (q-tail q) (q-head q))) + (t (setf (q-head q) (cons item (q-head q)))))) (defmethod queue-push ((q out-queue) item) (let ((windows (q-head (win-list q))) - (win (ms-win item))) + (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) @@ -136,40 +136,40 @@ (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) - (let ((new (make-queue))) - (setf (gethash win (win-queues q)) new) - (queue-push new item)) - (queue-push temp-queue item))))) + (let ((new (make-queue))) + (setf (gethash win (win-queues q)) new) + (queue-push new item)) + (queue-push temp-queue item))))) (defmethod dequeue ((q out-queue)) (if (empty-p q) nil (let ((windows (win-list q))) - (do* ((next (dequeue windows)) - (finished nil) - (val nil) - (temp-queue (gethash next (win-queues q)) - (gethash next (win-queues q)))) - (finished val) - (cond ((empty-p temp-queue) - (setf next (dequeue windows))) - (t (setf val (dequeue temp-queue)) - (unless (empty-p temp-queue) - (enqueue windows next)) - (setf finished t))))))) + (do* ((next (dequeue windows)) + (finished nil) + (val nil) + (temp-queue (gethash next (win-queues q)) + (gethash next (win-queues q)))) + (finished val) + (cond ((empty-p temp-queue) + (setf next (dequeue windows))) + (t (setf val (dequeue temp-queue)) + (unless (empty-p temp-queue) + (enqueue windows next)) + (setf finished t))))))) (defmethod dequeue ((q queue)) (prog1 (car (q-head q)) (if (not (empty-p q)) - (setf (q-head q) (cdr (q-head q)))) + (setf (q-head q) (cdr (q-head q)))) (if (null (q-head q)) - (progn - (setf (q-head q) nil) - (setf (q-tail q) nil))))) + (progn + (setf (q-head q) nil) + (setf (q-tail q) nil))))) (defun iter (rc ic max) (declare (double-float rc ic) - (fixnum max)) + (fixnum max)) (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc))) (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic))) (n 1 (the fixnum (1+ n)))) @@ -190,28 +190,28 @@ ;;;(defmethod print-object ((object zoomer) stream) ;;; (format stream " [~a ~a]>~%" -;;; (zoom-type object) (start-x object) (start-y object) -;;; (stop-x object) (stop-y object))) +;;; (zoom-type object) (start-x object) (start-y object) +;;; (stop-x object) (stop-y object))) (defun init-colours () (unless *colmap* (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) (setf (aref *colmap* 0) (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red 0 - :green 0 - :blue 0)))) + :drawable (xlib:screen-root *screen*) + :foreground (xlib:alloc-color + (xlib:screen-default-colormap *screen*) + (xlib:make-color :red 0 + :green 0 + :blue 0)))) (loop for index from 1 to 255 - do (setf (aref *colmap* index) - (xlib:create-gcontext - :drawable (xlib:screen-root *screen*) - :foreground (xlib:alloc-color - (xlib:screen-default-colormap *screen*) - (xlib:make-color :red (random 1.0) - :green (random 1.0) - :blue (random 1.0)))))))) + do (setf (aref *colmap* index) + (xlib:create-gcontext + :drawable (xlib:screen-root *screen*) + :foreground (xlib:alloc-color + (xlib:screen-default-colormap *screen*) + (xlib:make-color :red (random 1.0) + :green (random 1.0) + :blue (random 1.0)))))))) (defmacro modcol (col max) `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) @@ -220,30 +220,30 @@ (let ((col (modcol col max))) (xlib:draw-point win (aref *colmap* col) x y) (setf (aref (the (simple-array (integer 0 255) (512 512)) - (gethash win *backing-store*)) x y) col))) + (gethash win *backing-store*)) x y) col))) (defun display-help () (unless *helpwin* (setf *helpwin* (xlib:create-window - :parent (xlib:screen-root *screen*) - :x 512 - :y 512 - :width 310 - :height 180 - :event-mask (xlib:make-event-mask :exposure) - :backing-store :always - :background (xlib:screen-white-pixel *screen*))) + :parent (xlib:screen-root *screen*) + :x 512 + :y 512 + :width 310 + :height 180 + :event-mask (xlib:make-event-mask :exposure) + :backing-store :always + :background (xlib:screen-white-pixel *screen*))) (xlib:map-window *helpwin*) (xlib:display-force-output *display*)) (unless (xlib:gcontext-font *textmap*) (let ((fixed (xlib:list-fonts *display* "fixed")) - font) + font) (if fixed - (setf font (xlib:open-font *display* "fixed")) - (error "Could not open suitable font")) + (setf font (xlib:open-font *display* "fixed")) + (error "Could not open suitable font")) (setf (xlib:gcontext-font *textmap*) (if (consp fixed) - (car fixed) - fixed)))) + (car fixed) + fixed)))) (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") @@ -259,9 +259,9 @@ (display-help) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for y of-type fixnum from y-low to y-high - do - (loop for x of-type fixnum from x-low to x-high - do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) + do + (loop for x of-type fixnum from x-low to x-high + do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) (defun fill-square (win col x y s max) (declare (fixnum col x y s max)) @@ -269,31 +269,31 @@ (xlib:draw-rectangle win (aref *colmap* col) x y s s t) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for px of-type fixnum from x to (1- (+ x s)) - do (loop for py of-type fixnum from y to (1- (+ y s)) - do (setf (aref bs px py) col)))))) + do (loop for py of-type fixnum from y to (1- (+ y s)) + do (setf (aref bs px py) col)))))) (defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) (declare (xlib:window win) - (fixnum x y side maxiter) - (double-float bx by dx dy)) + (fixnum x y side maxiter) + (double-float bx by dx dy)) (let ((sq (make-mandel-square - :x x :y y :s side - :base-r bx :base-i by - :dr dx :di dy - :maxiter maxiter - :win win))) + :x x :y y :s side + :base-r bx :base-i by + :dr dx :di dy + :maxiter maxiter + :win win))) (queue-push *sysqueue* sq))) (defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) (declare (xlib:window win) - (double-float lx ly hx hy) - (fixnum maxiter)) + (double-float lx ly hx hy) + (fixnum maxiter)) (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) - (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) + (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) (setf (gethash win *winmap*) - (make-mandel-square :x 0 :y 0 :s 512 - :base-r lx :base-i ly - :dr dx :di dy :maxiter maxiter)) + (make-mandel-square :x 0 :y 0 :s 512 + :base-r lx :base-i ly + :dr dx :di dy :maxiter maxiter)) (make-square win 0 256 256 lx ly dx dy maxiter) (make-square win 256 256 256 lx ly dx dy maxiter) (make-square win 256 0 256 lx ly dx dy maxiter) @@ -301,150 +301,150 @@ (defun new-window (lx ly hx hy &optional (maxiter 1024)) (let ((win (xlib:create-window - :parent (xlib:screen-root *screen*) - :x (+ 100 (random 50)) :y (+ 100 (random 50)) - :width 512 :height 512 - :bit-gravity :center - :event-mask (xlib:make-event-mask - :button-motion :button-press :button-release - :key-press :exposure))) - (ar (make-array '(512 512) - :element-type '(integer 0 255) :initial-element 0)) - ) + :parent (xlib:screen-root *screen*) + :x (+ 100 (random 50)) :y (+ 100 (random 50)) + :width 512 :height 512 + :bit-gravity :center + :event-mask (xlib:make-event-mask + :button-motion :button-press :button-release + :key-press :exposure))) + (ar (make-array '(512 512) + :element-type '(integer 0 255) :initial-element 0)) + ) (setf (gethash win *backing-store*) ar) (xlib:map-window win) (mandel-win win - (coerce lx 'double-float) (coerce ly 'double-float) - (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) + (coerce lx 'double-float) (coerce ly 'double-float) + (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) (defun fill-square-p (ix iy s bx by dx dy max win) (declare (fixnum ix iy s max) - (double-float bx by dx dy)) + (double-float bx by dx dy)) (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) (and (loop for px from ix below (+ ix s) - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* iy dy)) - for i = (iter x y max) - do (plot win i px iy max) - while (= i norm) - finally (return t)) + for x of-type double-float = (+ bx (* px dx)) + with y = (+ by (* iy dy)) + for i = (iter x y max) + do (plot win i px iy max) + while (= i norm) + finally (return t)) (loop for py from iy below (+ s iy) - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* ix dx)) - for i = (iter x y max) - do (plot win i ix py max) - while (= i norm) - finally (return t)) + for y of-type double-float = (+ by (* py dy)) + with x = (+ bx (* ix dx)) + for i = (iter x y max) + do (plot win i ix py max) + while (= i norm) + finally (return t)) (loop for px from (1- (+ s ix)) downto ix - for x of-type double-float = (+ bx (* px dx)) - with y = (+ by (* dy (1- (+ s iy)))) - for i = (iter x y max) - do (plot win i px iy max) - if (/= i norm) return nil - finally (return t)) + for x of-type double-float = (+ bx (* px dx)) + with y = (+ by (* dy (1- (+ s iy)))) + for i = (iter x y max) + do (plot win i px iy max) + if (/= i norm) return nil + finally (return t)) (loop for py from (1- (+ s iy)) downto iy - for y of-type double-float = (+ by (* py dy)) - with x = (+ bx (* dx (1- (+ s ix)))) - for i = (iter x y max) - do (plot win i ix py max) - if (/= i norm) return nil - finally (return t))))) + for y of-type double-float = (+ by (* py dy)) + with x = (+ bx (* dx (1- (+ s ix)))) + for i = (iter x y max) + do (plot win i ix py max) + if (/= i norm) return nil + finally (return t))))) (defmacro z (base delta int) `(+ ,base (* ,delta ,int))) (defun draw-square (square) (declare (mandel-square square)) (let ((dx (ms-dr square)) - (dy (ms-di square)) - (base-x (ms-base-r square)) - (base-y (ms-base-i square)) - (maxiter (ms-maxiter square)) - (win (ms-win square)) - (x (ms-x square)) - (y (ms-y square)) - (s (ms-s square)) - ) + (dy (ms-di square)) + (base-x (ms-base-r square)) + (base-y (ms-base-i square)) + (maxiter (ms-maxiter square)) + (win (ms-win square)) + (x (ms-x square)) + (y (ms-y square)) + (s (ms-s square)) + ) (declare (double-float dx dy base-x base-y) - (fixnum x y s maxiter)) + (fixnum x y s maxiter)) (cond - ((= s 2) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) - (1+ x) (1+ y) maxiter) - (plot win - (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) - (1+ x) y maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) - x (1+ y) maxiter) - (plot win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y maxiter)) - ((fill-square-p x y s base-x base-y dx dy maxiter win) - (fill-square win - (iter (z base-x dx x) (z base-y dy y) maxiter) - x y s maxiter)) - (t (let ((new-s (/ s 2))) - (make-square win - x y new-s - base-x base-y - dx dy - maxiter) - (make-square win - x (+ y new-s) new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) y new-s - base-x base-y - dx dy - maxiter) - (make-square win - (+ x new-s) (+ y new-s) new-s - base-x base-y - dx dy - maxiter)))))) + ((= s 2) + (plot win + (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) + (1+ x) (1+ y) maxiter) + (plot win + (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) + (1+ x) y maxiter) + (plot win + (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) + x (1+ y) maxiter) + (plot win + (iter (z base-x dx x) (z base-y dy y) maxiter) + x y maxiter)) + ((fill-square-p x y s base-x base-y dx dy maxiter win) + (fill-square win + (iter (z base-x dx x) (z base-y dy y) maxiter) + x y s maxiter)) + (t (let ((new-s (/ s 2))) + (make-square win + x y new-s + base-x base-y + dx dy + maxiter) + (make-square win + x (+ y new-s) new-s + base-x base-y + dx dy + maxiter) + (make-square win + (+ x new-s) y new-s + base-x base-y + dx dy + maxiter) + (make-square win + (+ x new-s) (+ y new-s) new-s + base-x base-y + dx dy + maxiter)))))) (defun create-zoom (win x y button) (setf (gethash win *zoom-table*) - (make-instance 'zoomer - :x x :y y - :win win - :type (case button - (1 :zoom-same) - (2 :zoom-new) - (3 :zoom-out))))) + (make-instance 'zoomer + :x x :y y + :win win + :type (case button + (1 :zoom-same) + (2 :zoom-new) + (3 :zoom-out))))) (defun update-zoom (win x y code) (declare (ignore code) - (fixnum x y)) + (fixnum x y)) (let ((zoomer (gethash win *zoom-table*))) (when zoomer (let ((new-side (max 0 - (- (the fixnum x) (the fixnum (start-x zoomer))) - (- (the fixnum y) (the fixnum (start-y zoomer)))))) - (let ((old-side (max 0 - (- (the fixnum (stop-x zoomer)) - (the fixnum (start-x zoomer))) - (- (the fixnum (stop-y zoomer)) - (the fixnum (start-y zoomer)))))) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - old-side old-side)) - (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) - (the fixnum x) - )) - (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) - (the fixnum y) - )) - (xlib:draw-rectangle win *zoomcolmap* - (the fixnum (start-x zoomer)) - (the fixnum (start-y zoomer)) - new-side new-side) - (xlib:display-force-output *display*))))) + (- (the fixnum x) (the fixnum (start-x zoomer))) + (- (the fixnum y) (the fixnum (start-y zoomer)))))) + (let ((old-side (max 0 + (- (the fixnum (stop-x zoomer)) + (the fixnum (start-x zoomer))) + (- (the fixnum (stop-y zoomer)) + (the fixnum (start-y zoomer)))))) + (xlib:draw-rectangle win *zoomcolmap* + (the fixnum (start-x zoomer)) + (the fixnum (start-y zoomer)) + old-side old-side)) + (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) + (the fixnum x) + )) + (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) + (the fixnum y) + )) + (xlib:draw-rectangle win *zoomcolmap* + (the fixnum (start-x zoomer)) + (the fixnum (start-y zoomer)) + new-side new-side) + (xlib:display-force-output *display*))))) (defun finish-zoom (win x y code) (declare (ignore code)) @@ -457,46 +457,46 @@ (declare (zoomer zoomer)) (setf (gethash win *zoom-table*) nil) (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) - (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) - (sq (gethash win *winmap*))) + (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) + (sq (gethash win *winmap*))) (let ((side (max dx dy)) - (x (the fixnum (start-x zoomer))) - (y (the fixnum (start-y zoomer))) - lx hx ly hy - ) - (if (< side 5) - (setf lx (+ (ms-base-r sq) - (* (- x 128) (ms-dr sq))) - ly (+ (ms-base-i sq) - (* (- y 128) (ms-di sq))) - hx (+ (ms-base-r sq) - (* (+ x 128) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ y 128) (ms-di sq)))) - (setf lx (+ (ms-base-r sq) - (* x (ms-dr sq))) - ly (+ (ms-base-i sq) - (* y (ms-dr sq))) - hx (+ (ms-base-r sq) - (* (+ side x) (ms-dr sq))) - hy (+ (ms-base-i sq) - (* (+ side y) (ms-dr sq))))) -;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) - (case (zoom-type zoomer) - (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) - (:zoom-same (empty-win *sysqueue* win) - (mandel-win win lx ly hx hy (ms-maxiter sq))) - (:zoom-out (empty-win *sysqueue* win) - (let ((br (ms-base-r sq)) - (bi (ms-base-i sq)) - (dr (ms-dr sq)) - (di (ms-di sq))) - (mandel-win win - (- br (* 512 dr)) (- bi (* 512 di)) - (+ (* 1024 dr) br) (+ (* 1024 di) bi) - (ms-maxiter sq)))) - - (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) + (x (the fixnum (start-x zoomer))) + (y (the fixnum (start-y zoomer))) + lx hx ly hy + ) + (if (< side 5) + (setf lx (+ (ms-base-r sq) + (* (- x 128) (ms-dr sq))) + ly (+ (ms-base-i sq) + (* (- y 128) (ms-di sq))) + hx (+ (ms-base-r sq) + (* (+ x 128) (ms-dr sq))) + hy (+ (ms-base-i sq) + (* (+ y 128) (ms-di sq)))) + (setf lx (+ (ms-base-r sq) + (* x (ms-dr sq))) + ly (+ (ms-base-i sq) + (* y (ms-dr sq))) + hx (+ (ms-base-r sq) + (* (+ side x) (ms-dr sq))) + hy (+ (ms-base-i sq) + (* (+ side y) (ms-dr sq))))) +;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) + (case (zoom-type zoomer) + (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) + (:zoom-same (empty-win *sysqueue* win) + (mandel-win win lx ly hx hy (ms-maxiter sq))) + (:zoom-out (empty-win *sysqueue* win) + (let ((br (ms-base-r sq)) + (bi (ms-base-i sq)) + (dr (ms-dr sq)) + (di (ms-di sq))) + (mandel-win win + (- br (* 512 dr)) (- bi (* 512 di)) + (+ (* 1024 dr) br) (+ (* 1024 di) bi) + (ms-maxiter sq)))) + + (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) (defun quit-window (window) (let ((temp (gethash window (win-queues *sysqueue*)))) @@ -510,49 +510,49 @@ ((eq quit 'quit)) (xlib:event-case (*display* :timeout 0) (:button-press (window x y code) - (create-zoom window x y code) - t) + (create-zoom window x y code) + t) (:button-release (window x y code) - (finish-zoom window x y code) - (do-zoom window) - t) + (finish-zoom window x y code) + (do-zoom window) + t) (:motion-notify (window x y code) - (update-zoom window x y code) - t) + (update-zoom window x y code) + t) (:exposure (window x y width height count) - (let ((count count)) - (declare (ignore count) - (fixnum x y width height)) - (when redisplay - (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) - t) + (let ((count count)) + (declare (ignore count) + (fixnum x y width height)) + (when redisplay + (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) + t) (:key-press (window code) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code (make-shift-foo))) - (#\q (quit-window window)) - (#\? (display-help)) - ((:left-shift :right-shift) - (push :shift *modstate*)) - ((:left-control :right-control) - (push :ctrl *modstate*)) - (:character-set-switch - (push :character-set-switch *modstate*))) - t) + (case (xlib:keysym->character + *display* + (xlib:keycode->keysym *display* code (make-shift-foo))) + (#\q (quit-window window)) + (#\? (display-help)) + ((:left-shift :right-shift) + (push :shift *modstate*)) + ((:left-control :right-control) + (push :ctrl *modstate*)) + (:character-set-switch + (push :character-set-switch *modstate*))) + t) (:key-release (window code) - (let ((window window)) - (declare (ignore window)) - (case (xlib:keysym->character - *display* - (xlib:keycode->keysym *display* code 0)) - (:character-set-switch - (setf *modstate* (delete :character-set-switch *modstate*))) - ((:left-control :right-control) - (setf *modstate* (delete :ctrl *modstate*))) - ((:left-shift :right-shift) - (setf *modstate* (delete :shift *modstate*))))) - t)) + (let ((window window)) + (declare (ignore window)) + (case (xlib:keysym->character + *display* + (xlib:keycode->keysym *display* code 0)) + (:character-set-switch + (setf *modstate* (delete :character-set-switch *modstate*))) + ((:left-control :right-control) + (setf *modstate* (delete :ctrl *modstate*))) + ((:left-shift :right-shift) + (setf *modstate* (delete :shift *modstate*))))) + t)) (cond ((empty-p *sysqueue*) - nil) - (t (let ((square (dequeue *sysqueue*))) - (draw-square square)))))) + nil) + (t (let ((square (dequeue *sysqueue*))) + (draw-square square)))))) diff --git a/src/clx/demo/menu.lisp b/src/clx/demo/menu.lisp index 5de1d0726..3919c2622 100644 --- a/src/clx/demo/menu.lisp +++ b/src/clx/demo/menu.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1988 Texas Instruments Incorporated. ;;; @@ -32,14 +32,14 @@ (defstruct (menu) "A simple menu of text strings." (title "choose an item:") - item-alist ;((item-window item-string)) + item-alist ;((item-window item-string)) window gcontext width title-width item-width item-height - (geometry-changed-p t)) ;nil iff unchanged since displayed + (geometry-changed-p t)) ;nil iff unchanged since displayed @@ -47,24 +47,24 @@ (make-menu ;; Create menu graphics context :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) + :foreground text-color + :background background-color + :font text-font) ;; Create menu window :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) + :parent parent-window + :class :input-output + :x 0 ;temporary value + :y 0 ;temporary value + :width 16 ;temporary value + :height 16 ;temporary value + :border-width 2 + :border text-color + :background background-color + :save-under :on + :override-redirect :on ;override window mgr when positioning + :event-mask (MAKE-EVENT-MASK :leave-window + :exposure)))) (defun menu-set-item-list (menu &rest item-strings) @@ -77,21 +77,21 @@ ;; Add (item-window item-string) elements to item-alist (setf (menu-item-alist menu) - (let (alist) - (dolist (item item-strings (nreverse alist)) - (push (list (CREATE-WINDOW - :parent (menu-window menu) - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) - :event-mask (MAKE-EVENT-MASK :enter-window - :leave-window - :button-press - :button-release)) - item) - alist))))) + (let (alist) + (dolist (item item-strings (nreverse alist)) + (push (list (CREATE-WINDOW + :parent (menu-window menu) + :x 0 ;temporary value + :y 0 ;temporary value + :width 16 ;temporary value + :height 16 ;temporary value + :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) + :event-mask (MAKE-EVENT-MASK :enter-window + :leave-window + :button-press + :button-release)) + item) + alist))))) (defparameter *menu-item-margin* 4 "Minimum number of pixels surrounding menu items.") @@ -100,51 +100,51 @@ (defun menu-recompute-geometry (menu) (when (menu-geometry-changed-p menu) (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) - (title-width (TEXT-EXTENTS menu-font (menu-title menu))) - (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) - (item-width 0) - (items (menu-item-alist menu)) - menu-width) + (title-width (TEXT-EXTENTS menu-font (menu-title menu))) + (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) + (item-width 0) + (items (menu-item-alist menu)) + menu-width) ;; Find max item string width (dolist (next-item items) - (setf item-width (max item-width - (TEXT-EXTENTS menu-font (second next-item))))) + (setf item-width (max item-width + (TEXT-EXTENTS menu-font (second next-item))))) ;; Compute final menu width, taking margins into account (setf menu-width (max title-width - (+ item-width *menu-item-margin* *menu-item-margin*))) + (+ item-width *menu-item-margin* *menu-item-margin*))) (let ((window (menu-window menu)) - (delta-y (+ item-height *menu-item-margin*))) - - ;; Update width and height of menu window - (WITH-STATE (window) - (setf (DRAWABLE-WIDTH window) menu-width - (DRAWABLE-HEIGHT window) (+ *menu-item-margin* - (* (1+ (length items)) - delta-y)))) - - ;; Update width, height, position of item windows - (let ((item-left (round (- menu-width item-width) 2)) - (next-item-top delta-y)) - (dolist (next-item items) - (let ((window (first next-item))) - (WITH-STATE (window) - (setf (DRAWABLE-HEIGHT window) item-height - (DRAWABLE-WIDTH window) item-width - (DRAWABLE-X window) item-left - (DRAWABLE-Y window) next-item-top))) - (incf next-item-top delta-y)))) + (delta-y (+ item-height *menu-item-margin*))) + + ;; Update width and height of menu window + (WITH-STATE (window) + (setf (DRAWABLE-WIDTH window) menu-width + (DRAWABLE-HEIGHT window) (+ *menu-item-margin* + (* (1+ (length items)) + delta-y)))) + + ;; Update width, height, position of item windows + (let ((item-left (round (- menu-width item-width) 2)) + (next-item-top delta-y)) + (dolist (next-item items) + (let ((window (first next-item))) + (WITH-STATE (window) + (setf (DRAWABLE-HEIGHT window) item-height + (DRAWABLE-WIDTH window) item-width + (DRAWABLE-X window) item-left + (DRAWABLE-Y window) next-item-top))) + (incf next-item-top delta-y)))) ;; Map all item windows (MAP-SUBWINDOWS (menu-window menu)) ;; Save item geometry (setf (menu-item-width menu) item-width - (menu-item-height menu) item-height - (menu-width menu) menu-width - (menu-title-width menu) title-width - (menu-geometry-changed-p menu) nil)))) + (menu-item-height menu) item-height + (menu-width menu) menu-width + (menu-title-width menu) title-width + (menu-geometry-changed-p menu) nil)))) (defun menu-refresh (menu) @@ -153,22 +153,22 @@ ;; Show title centered in "reverse-video" (let ((fg (GCONTEXT-BACKGROUND gcontext)) - (bg (GCONTEXT-FOREGROUND gcontext))) + (bg (GCONTEXT-FOREGROUND gcontext))) (WITH-GCONTEXT (gcontext :foreground fg :background bg) (DRAW-IMAGE-GLYPHS - (menu-window menu) - gcontext - (round (- (menu-width menu) - (menu-title-width menu)) 2) ;start x - baseline-y ;start y - (menu-title menu)))) + (menu-window menu) + gcontext + (round (- (menu-width menu) + (menu-title-width menu)) 2) ;start x + baseline-y ;start y + (menu-title menu)))) ;; Show each menu item (position is relative to item window) (dolist (item (menu-item-alist menu)) (DRAW-IMAGE-GLYPHS (first item) gcontext - 0 ;start x - baseline-y ;start y + 0 ;start x + baseline-y ;start y (second item))))) @@ -177,44 +177,44 @@ (menu-present menu x y) (let ((items (menu-item-alist menu)) - (mw (menu-window menu)) - selected-item) + (mw (menu-window menu)) + selected-item) ;; Event processing loop - (do () (selected-item) + (do () (selected-item) (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) - (:exposure (count) - - ;; Discard all but final :exposure then display the menu - (when (zerop count) (menu-refresh menu)) - t) - - (:button-release (event-window) - ;;Select an item - (setf selected-item (second (assoc event-window items))) - t) - - (:enter-notify (window) - ;;Highlight an item - (let ((position (position window items :key #'first))) - (when position - (menu-highlight-item menu position))) - t) - - (:leave-notify (window kind) - (if (eql mw window) - ;; Quit if pointer moved out of main menu window - (setf selected-item (when (eq kind :ancestor) :none)) + (:exposure (count) + + ;; Discard all but final :exposure then display the menu + (when (zerop count) (menu-refresh menu)) + t) + + (:button-release (event-window) + ;;Select an item + (setf selected-item (second (assoc event-window items))) + t) + + (:enter-notify (window) + ;;Highlight an item + (let ((position (position window items :key #'first))) + (when position + (menu-highlight-item menu position))) + t) + + (:leave-notify (window kind) + (if (eql mw window) + ;; Quit if pointer moved out of main menu window + (setf selected-item (when (eq kind :ancestor) :none)) - ;; Otherwise, unhighlight the item window left - (let ((position (position window items :key #'first))) - (when position - (menu-unhighlight-item menu position)))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) + ;; Otherwise, unhighlight the item window left + (let ((position (position window items :key #'first))) + (when position + (menu-unhighlight-item menu position)))) + t) + + (otherwise () + ;;Ignore and discard any other event + t))) ;; Erase the menu (UNMAP-WINDOW mw) @@ -225,19 +225,19 @@ (defun menu-highlight-item (menu position) (let* ((box-margin (round *menu-item-margin* 2)) - (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) - box-margin)) - (top (- (* (+ *menu-item-margin* (menu-item-height menu)) - (1+ position)) - box-margin)) - (width (+ (menu-item-width menu) box-margin box-margin)) - (height (+ (menu-item-height menu) box-margin box-margin))) + (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) + box-margin)) + (top (- (* (+ *menu-item-margin* (menu-item-height menu)) + (1+ position)) + box-margin)) + (width (+ (menu-item-width menu) box-margin box-margin)) + (height (+ (menu-item-height menu) box-margin box-margin))) ;; Draw a box in menu window around the given item. (DRAW-RECTANGLE (menu-window menu) - (menu-gcontext menu) - left top - width height))) + (menu-gcontext menu) + left top + width height))) (defun menu-unhighlight-item (menu position) ;; Draw a box in the menu background color @@ -256,67 +256,67 @@ (multiple-value-bind (tree parent) (QUERY-TREE menu-window) (declare (ignore tree)) (WITH-STATE (parent) - (let* ((parent-width (DRAWABLE-WIDTH parent)) - (parent-height (DRAWABLE-HEIGHT parent)) - (menu-height (+ *menu-item-margin* - (* (1+ (length (menu-item-alist menu))) - (+ (menu-item-height menu) *menu-item-margin*)))) - (menu-x (max 0 (min (- parent-width (menu-width menu)) - (- x (round (menu-width menu) 2))))) - (menu-y (max 0 (min (- parent-height menu-height) - (- y (round (menu-item-height menu) 2/3) - *menu-item-margin*))))) - (WITH-STATE (menu-window) - (setf (DRAWABLE-X menu-window) menu-x - (DRAWABLE-Y menu-window) menu-y))))) + (let* ((parent-width (DRAWABLE-WIDTH parent)) + (parent-height (DRAWABLE-HEIGHT parent)) + (menu-height (+ *menu-item-margin* + (* (1+ (length (menu-item-alist menu))) + (+ (menu-item-height menu) *menu-item-margin*)))) + (menu-x (max 0 (min (- parent-width (menu-width menu)) + (- x (round (menu-width menu) 2))))) + (menu-y (max 0 (min (- parent-height menu-height) + (- y (round (menu-item-height menu) 2/3) + *menu-item-margin*))))) + (WITH-STATE (menu-window) + (setf (DRAWABLE-X menu-window) menu-x + (DRAWABLE-Y menu-window) menu-y))))) ;; Make menu visible (MAP-WINDOW menu-window))) (defun just-say-lisp (&optional (font-name "fixed")) (let* ((display (open-default-display)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) + (screen (first (DISPLAY-ROOTS display))) + (fg-color (SCREEN-BLACK-PIXEL screen)) + (bg-color (SCREEN-WHITE-PIXEL screen)) + (nice-font (OPEN-FONT display font-name)) + (a-menu (create-menu (screen-root screen) ;the menu's parent + fg-color bg-color nice-font))) (setf (menu-title a-menu) "Please pick your favorite language:") (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") ;; Bedevil the user until he picks a nice programming language (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) + (do (choice) + ((and (setf choice (menu-choose a-menu 100 100)) + (string-equal "Lisp" choice)))) (CLOSE-DISPLAY display)))) (defun pop-up (host strings &key (title "Pick one:") (font "fixed")) (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) + (screen (first (DISPLAY-ROOTS display))) + (fg-color (SCREEN-BLACK-PIXEL screen)) + (bg-color (SCREEN-WHITE-PIXEL screen)) + (font (OPEN-FONT display font)) + (parent-width 400) + (parent-height 400) + (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) + :override-redirect :on + :x 100 :y 100 + :width parent-width :height parent-height + :background bg-color + :event-mask (MAKE-EVENT-MASK :button-press + :exposure))) + (a-menu (create-menu parent fg-color bg-color font)) + (prompt "Press a button...") + (prompt-gc (CREATE-GCONTEXT :drawable parent + :foreground fg-color + :background bg-color + :font font)) + (prompt-y (FONT-ASCENT font)) + (ack-y (- parent-height (FONT-DESCENT font)))) (setf (menu-title a-menu) title) (apply #'menu-set-item-list a-menu strings) @@ -325,58 +325,58 @@ (MAP-WINDOW parent) (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) + (window string gcontext height width) + (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) + (declare (ignore a d l r)) + (let ((box-height (+ fa fd))) + + ;; Clear previous text + (CLEAR-AREA window + :x 0 :y (- height fa) + :width width :height box-height) + + ;; Draw new text + (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) + (loop + (EVENT-CASE (display :force-output-p t) + + (:exposure (count) + + ;; Display prompt + (when (zerop count) + (display-centered-text + parent + prompt + prompt-gc + prompt-y + parent-width)) + t) + + (:button-press (x y) + + ;; Pop up the menu + (let ((choice (menu-choose a-menu x y))) + (if choice + (display-centered-text + parent + (format nil "You have selected ~a." choice) + prompt-gc + ack-y + parent-width) + + (display-centered-text + parent + "No selection...try again." + prompt-gc + ack-y + parent-width))) + t) + + (otherwise () + ;;Ignore and discard any other event + t))) + + (CLOSE-DISPLAY display))))) diff --git a/src/clx/demo/zoid.lisp b/src/clx/demo/zoid.lisp index 0a313059f..97e5b6fe2 100644 --- a/src/clx/demo/zoid.lisp +++ b/src/clx/demo/zoid.lisp @@ -3,9 +3,9 @@ ;;; CLX interface for Trapezoid Extension. ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -21,8 +21,8 @@ (in-package :xlib) (export '(draw-filled-trapezoids - gcontext-trapezoid-alignment ;; Setf'able - )) + gcontext-trapezoid-alignment ;; Setf'able + )) (define-extension "ZoidExtension") @@ -34,10 +34,10 @@ ;; Alignment is set with the ALIGNMENT keyword argument, which may be ;; :X, :Y, or NIL (use previous alignment) (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points)) + (type gcontext gcontext) + (type sequence points)) (let* ((display (drawable-display drawable)) - (opcode (extension-opcode display "ZoidExtension"))) + (opcode (extension-opcode display "ZoidExtension"))) (with-buffer-request (display opcode :gc-force gcontext) ((data card8) 1) ;; X_PolyFillZoid (drawable drawable) @@ -50,7 +50,7 @@ (defun set-trapezoid-alignment (gcontext alignment) (declare (type (member :x :y) alignment)) (let* ((display (gcontext-display gcontext)) - (opcode (extension-opcode display "ZoidExtension"))) + (opcode (extension-opcode display "ZoidExtension"))) (with-buffer-request (display opcode) ((data card8) 2) ;; X_SetZoidAlignment (gcontext gcontext) diff --git a/src/clx/dep-allegro.lisp b/src/clx/dep-allegro.lisp index 3281a2721..ce5d27ee8 100644 --- a/src/clx/dep-allegro.lisp +++ b/src/clx/dep-allegro.lisp @@ -3,9 +3,9 @@ ;; This file contains some of the system dependent code for CLX ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -59,9 +59,9 @@ "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals @@ -70,13 +70,13 @@ ;; is 0. (defun declare-buffun () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) + card16->int16 int16->card16 + card32->int32 int32->card32)) #-Genera (progn @@ -86,8 +86,8 @@ (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) + (the int8 (- x #x100)) + x))) (defun int8->card8 (x) (declare (type int8 x)) @@ -100,8 +100,8 @@ (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) + (the int16 (- x #x10000)) + x))) (defun int16->card16 (x) (declare (type int16 x)) @@ -114,8 +114,8 @@ (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) + (the int32 (- x #x100000000)) + x))) (defun int32->card32 (x) (declare (type int32 x)) @@ -129,7 +129,7 @@ #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays (not Genera)) (progn @@ -173,115 +173,115 @@ (defun aref-card8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte))) + :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-byte) v)) + :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte))) + :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-byte) v)) + :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word))) + :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-word) v)) + :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word))) + :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-word) v)) + :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) + :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) + :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long))) + :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :signed-long) v)) + :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long))) + :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i - :unsigned-long) v)) + :unsigned-long) v)) ) @@ -369,146 +369,146 @@ (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) + (let ((alist + `(#-lispm + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) + ;; The rest of the common lisp charater set with the normal + ;; ascii codes for them. + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-array 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + #-Genera + (progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char + (or (aref (the simple-vector *card8-to-char-translation-table*) + card8) + (error "Invalid CHAR code ~D." card8)))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + #-Minima + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + #-Minima + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char (code-char card8))) + )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. @@ -540,38 +540,38 @@ ;;; #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect - (block .hl-doit. - (when (sys:scheduler-running-p) ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) + (block .hl-doit. + (when (sys:scheduler-running-p) ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + ;; There is an apparent race condition here. However, there is + ;; no actual race condition -- our implementation of mp:process- + ;; lock guarantees that the lock will still be held when it + ;; returns, and no interrupt can happen between that and the + ;; execution of the next form. -- jdi 2/27/91 + (setq .hl-obtained-lock. t))) + ,@body) (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) ;;; WITHOUT-ABORTS @@ -593,7 +593,7 @@ (if (sys:scheduler-running-p) (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) + (error "Program tried to wait with no scheduler.")))) ;;; PROCESS-WAKEUP: Check some other process' wait function. @@ -604,11 +604,11 @@ (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) + (error "~s is not a process" curproc)) (unless (mp::process-p process) - (error "~s is not a process" process)) + (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) + (mp::process-allow-schedule process))))) ;;; CURRENT-PROCESS: Return the current process object for input locking and @@ -633,13 +633,13 @@ (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) + (setf ,place ,new-value) + t)))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- @@ -658,8 +658,8 @@ ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X @@ -674,10 +674,10 @@ (defun open-x-stream (host display protocol) (declare (ignore protocol)) ;; assume TCP (let ((stream (socket:make-socket :remote-host (string host) - :remote-port (+ *x-tcp-port* display) - :format :binary))) + :remote-port (+ *x-tcp-port* display) + :format :binary))) (if (streamp stream) - stream + stream (error "Cannot connect to server: ~A:~D" host display)))) @@ -690,25 +690,25 @@ #+excl (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) - (fd (display-input-stream display))) + (fd (display-input-stream display))) (declare (type array-index howmany)) (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) ;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. +;;; CLX performance will suffer if your lisp uses read-byte for +;;; receiving all data from the X Window System server. +;;; You are encouraged to write a specialized version of +;;; buffer-read-default that does block transfers. ;;; BUFFER-WRITE-DEFAULT - write data to the X stream @@ -716,8 +716,8 @@ #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (unless (null stream) @@ -725,10 +725,10 @@ ) ;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. +;;; CLX performance will be severely degraded if your lisp uses +;;; write-byte to send all data to the X Window System server. +;;; You are STRONGLY encouraged to write a specialized version +;;; of buffer-write-default that does block transfers. ;;; buffer-force-output-default - force output to the X stream @@ -777,50 +777,50 @@ #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (when (streamp fd) (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - ((sys:scheduler-running-p) - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - ) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - #+mswindows - (error "scheduler must be running to use CLX on MS Windows") - #-mswindows - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (= timeout 0)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + ((sys:scheduler-running-p) + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + ) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + #+mswindows + (error "scheduler must be running to use CLX on MS Windows") + #-mswindows + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) - + ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. @@ -832,7 +832,7 @@ (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) - t + t (listen stream)))) #+(and excl (not clx-use-allegro-streams)) @@ -841,7 +841,7 @@ (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) - t + t (fd-char-avail-p fd)))) @@ -863,7 +863,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm @@ -874,58 +874,58 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) #+excl (defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) + target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) + (> target-start source-start)) then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) + &body body) (let ((local-state (gensym)) - (resets nil)) + (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) + resets)) `(unwind-protect - (progn - ,@body) + (progn + ,@body) (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- @@ -985,23 +985,23 @@ (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, @@ -1009,9 +1009,9 @@ (defun x-type-error (object type &optional error-string) (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) + :datum object + :expected-type type + :type-string error-string)) ;;----------------------------------------------------------------------------- @@ -1021,9 +1021,9 @@ ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) + &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) + (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous @@ -1054,19 +1054,19 @@ (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) + (warn "Disabled event handling on ~S." disp) + (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) + (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) + (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] @@ -1078,7 +1078,7 @@ `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) + slots) ,@args)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) @@ -1105,45 +1105,45 @@ (ecase family (:internet (cons :internet - (multiple-value-list - (socket::ipaddr-to-dotted (socket::lookup-hostname host) - :values t)))))) + (multiple-value-list + (socket::ipaddr-to-dotted (socket::lookup-hostname host) + :values t)))))) #+(and allegro-version>= (not (version>= 5 0))) (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) + (progn + (setf hostent (ipc::gethostbyname (string host))) + (when (zerop hostent) + (no-host-error)) + (ecase family + ((:internet nil 0) + (unless (= (ipc::hostent-addrtype hostent) 2) + (no-address-error)) + (assert (= (ipc::hostent-length hostent) 4)) + (let ((addr (ipc::hostent-addr hostent))) + (when (or (member comp::.target. + '(:hp :sgi4d :sony :dec3100) + :test #'eq) + (probe-file "/lib/ld.so")) + ;; BSD 4.3 based systems require an extra indirection + (setq addr (si:memref-int addr 0 0 :unsigned-long))) + (list :internet + (si:memref-int addr 0 0 :unsigned-byte) + (si:memref-int addr 1 0 :unsigned-byte) + (si:memref-int addr 2 0 :unsigned-byte) + (si:memref-int addr 3 0 :unsigned-byte)))))) + (ff:free-cstruct hostent))))) ;;----------------------------------------------------------------------------- @@ -1197,8 +1197,8 @@ (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) + (and string + (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) @@ -1206,8 +1206,8 @@ (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) + (and xauthority + (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think @@ -1230,28 +1230,28 @@ C language bindings Returns a list of (host display-number screen protocol)." (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) + (getenv "DISPLAY") + (error "DISPLAY environment variable is not set"))) + (slash-i (or (position #\/ name) -1)) + (colon-i (position #\: name :start (1+ slash-i))) + (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) + (host (subseq name (1+ slash-i) colon-i)) + (dot-i (and colon-i (position #\. name :start colon-i))) + (display (when colon-i + (parse-integer name + :start (if decnet-colon-p + (+ colon-i 2) + (1+ colon-i)) + :end dot-i))) + (screen (when dot-i + (parse-integer name :start (1+ dot-i)))) + (protocol + (cond ((or (string= host "") (string-equal host "unix")) :local) + (decnet-colon-p :decnet) + ((> slash-i -1) (intern + (string-upcase (subseq name 0 slash-i)) + :keyword)) + (t :internet)))) (list host (or display 0) (or screen 0) protocol))) @@ -1261,10 +1261,10 @@ Returns a list of (host display-number screen protocol)." (defun gc-cleanup () (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) @@ -1282,22 +1282,22 @@ Returns a list of (host display-number screen protocol)." #-(or clx-ansi-common-lisp Genera CMU sbcl) (defun with-standard-io-syntax-function (function) (declare #+lispm - (sys:downward-funarg function)) + (sys:downward-funarg function)) (let ((*package* (find-package :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-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - ) + (*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-pretty* nil) + (*print-radix* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-suppress* nil) + ) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl) @@ -1324,23 +1324,23 @@ Returns a list of (host display-number screen protocol)." #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) + (type card16 state) + (type t object) + (clx-values t) + (special left-meta-keysym right-meta-keysym + left-super-keysym right-super-keysym + left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) + (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) + (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) + (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) @@ -1403,7 +1403,7 @@ Returns a list of (host display-number screen protocol)." #+excl (defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) + ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) @@ -1415,9 +1415,9 @@ Returns a list of (host display-number screen protocol)." (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) + (#-Genera ldb #+Genera sys:%logldb + (byte ,size ,position) + (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. @@ -1425,13 +1425,13 @@ Returns a list of (host display-number screen protocol)." (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) - (count 0)) + (count 0)) (dolist (byte (rest bytes)) (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) + `(#-Genera dpb #+Genera sys:%logdpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) @@ -1442,11 +1442,11 @@ Returns a list of (host display-number screen protocol)." integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) + (#-Genera ldb #+Genera sys:%logldb + (byte 8 ,position) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,integer + ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. @@ -1454,13 +1454,13 @@ Returns a list of (host display-number screen protocol)." (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) + (it (first bytes)) + (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) + (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) @@ -1476,29 +1476,29 @@ Returns a list of (host display-number screen protocol)." ;;; for the least significant bit. ;;; ;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant ;;; ;;; -;;; format ordering +;;; format ordering ;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant @@ -1521,31 +1521,31 @@ Returns a list of (host display-number screen protocol)." (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) + (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (declare (type (simple-array bit (* *)) a) + (type fixnum i n)) + (with-underlying-simple-vector (v (unsigned-byte 8) a) + (prog2 + (setf (aref v i) n) + (dotimes (i 32) + (unless (zerop (aref a 0 i)) + (return i))) + (setf (aref v i) 0))))) + (list (bitpos a i #b10000000) + (bitpos a i #b00000001))) + ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) + (second (assoc ordering *image-bit-ordering-table* + :test #'equal)))) (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ + (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" - ordering)) + ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) @@ -1568,216 +1568,216 @@ Returns a list of (host display-number screen protocol)." #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (the array-index (mod (the fixnum (- x)) 8))) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (the fixnum (- (the fixnum (- width left-bits)) + right-bits))) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bytes) + (fixnum middle-bits)) + (cond ((< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) + 2))) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) t) ;;; COPY-BIT-RECT -- Internal @@ -1790,421 +1790,421 @@ Returns a list of (host display-number screen protocol)." #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod x-bits 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod x-bits +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p*) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (dst card8 pixarray) + (funcall + (symbol-function image-swap-function) bbuf dst + (index+ boffset + (index* y padded-bytes-per-line) + (index-floor x-bits 8)) + 0 (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line + (index-floor pixarray-padded-bits-per-line 8) + height image-swap-lsb-first-p))) + t)))) (defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + x y width height padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-read-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-read-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-read-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-read-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-read-pixarray-24)))) (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) + (read-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) + pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (src card8 pixarray) + (funcall + (symbol-function image-swap-function) + src bbuf (index-floor pixarray-start-bit-offset 8) boffset + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + padded-bytes-per-line height image-swap-lsb-first-p)) + t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-write-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-write-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-write-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-write-pixarray-24)))) (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) + (write-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ + unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (array-dimension copy 1)) + (copy-padded-bits-per-line + (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) + (zerop (index-mod pixarray-padded-bits-per-line 32)) + (zerop (index-mod copy-padded-bits-per-line 32))) + (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t) #+(or CMU) (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - + (pixarray-element-size copy) + bits-per-pixel) + (copy-bit-rect pixarray pixarray-padded-bits-per-line x y + copy copy-padded-bits-per-line 0 0 + height + (index* width bits-per-pixel)) + t)) + #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (copy-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index copy 1 0) + (array-row-major-index copy 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + copy-padded-bits-per-line pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod copy-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (with-underlying-simple-vector (src card8 pixarray) + (with-underlying-simple-vector (dst card8 copy) + (image-noswap + src dst + (index-floor pixarray-start-bit-offset 8) 0 + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + (index-floor copy-padded-bits-per-line 8) + height nil))) + t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) + `(let ((pixarray pixarray) + (copy copy)) + (declare (type ,type pixarray copy)) + #.(declare-buffun) + (with-underlying-simple-vector (src ,element-type pixarray) + (with-underlying-simple-vector (dst ,element-type copy) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) t))) diff --git a/src/clx/dep-openmcl.lisp b/src/clx/dep-openmcl.lisp index 44a0c3e23..bda4e9b41 100644 --- a/src/clx/dep-openmcl.lisp +++ b/src/clx/dep-openmcl.lisp @@ -3,9 +3,9 @@ ;; This file contains some of the system dependent code for CLX ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -49,9 +49,9 @@ "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals @@ -60,13 +60,13 @@ ;; is 0. (defun declare-buffun () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) + card16->int16 int16->card16 + card32->int32 int32->card32)) (progn @@ -75,8 +75,8 @@ (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) + (the int8 (- x #x100)) + x))) (defun int8->card8 (x) (declare (type int8 x)) @@ -89,8 +89,8 @@ (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) + (the int16 (- x #x10000)) + x))) (defun int16->card16 (x) (declare (type int16 x)) @@ -103,8 +103,8 @@ (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) + (the int32 (- x #x100000000)) + x))) (defun int32->card32 (x) (declare (type int32 x)) @@ -120,29 +120,29 @@ (defun aref-card8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) @@ -152,120 +152,120 @@ (defun aref-card16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) + (ash (the card8 (aref a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) + (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) @@ -335,129 +335,129 @@ (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () - (let ((alist - `( - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - - ;; The rest of the common lisp charater set with + (let ((alist + `( + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + + ;; The rest of the common lisp charater set with ;; the normal ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-array 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + (progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char + (or (aref (the simple-vector *card8-to-char-translation-table*) + card8) + (error "Invalid CHAR code ~D." card8)))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char (code-char card8))) + )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. @@ -472,7 +472,7 @@ ;;; work for event-listen you should do for holding-lock. (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore timeout display)) `(ccl:with-lock-grabbed (,locator ,whostate) ,@body)) @@ -528,8 +528,8 @@ ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- @@ -546,8 +546,8 @@ ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X @@ -559,35 +559,35 @@ (if local-socket-path (ccl::make-socket :connect :active :address-family :file - :remote-filename local-socket-path) + :remote-filename local-socket-path) (ccl::make-socket :connect :active :remote-host host - :remote-port (+ 6000 display))))) + :remote-port (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (progn - (ccl:stream-read-ivector stream vector start (- end start)) - nil)))) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (progn + (ccl:stream-read-ivector stream vector start (- end start)) + nil)))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) @@ -623,16 +623,16 @@ (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null number) timeout)) + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (let* ((fd (ccl::stream-device stream :input)) - (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) - (if (ccl::process-input-wait fd ticks) + ((listen stream) nil) + ((eql timeout 0) :timeout) + (t + (let* ((fd (ccl::stream-device stream :input)) + (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) + (if (ccl::process-input-wait fd ticks) nil :timeout)))))) @@ -647,7 +647,7 @@ (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) - t + t (listen stream)))) @@ -669,7 +669,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) @@ -686,25 +686,25 @@ (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) + &body body) (let ((local-state (gensym)) - (resets nil)) + (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) + resets)) `(unwind-protect - (progn - ,@body) + (progn + ,@body) (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- @@ -758,19 +758,19 @@ (progn (setq type (eval type)) (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, @@ -778,9 +778,9 @@ (defun x-type-error (object type &optional error-string) (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) + :datum object + :expected-type type + :type-string error-string)) ;;----------------------------------------------------------------------------- @@ -790,9 +790,9 @@ ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) + &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) + (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous @@ -824,7 +824,7 @@ ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) @@ -880,8 +880,8 @@ (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) + (and string + (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) @@ -889,8 +889,8 @@ (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) + (and xauthority + (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think @@ -913,28 +913,28 @@ C language bindings Returns a list of (host display-number screen protocol)." (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) + (getenv "DISPLAY") + (error "DISPLAY environment variable is not set"))) + (slash-i (or (position #\/ name) -1)) + (colon-i (position #\: name :start (1+ slash-i))) + (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) + (host (subseq name (1+ slash-i) colon-i)) + (dot-i (and colon-i (position #\. name :start colon-i))) + (display (when colon-i + (parse-integer name + :start (if decnet-colon-p + (+ colon-i 2) + (1+ colon-i)) + :end dot-i))) + (screen (when dot-i + (parse-integer name :start (1+ dot-i)))) + (protocol + (cond ((or (string= host "") (string-equal host "unix")) :local) + (decnet-colon-p :decnet) + ((> slash-i -1) (intern + (string-upcase (subseq name 0 slash-i)) + :keyword)) + (t :internet)))) (list host (or display 0) (or screen 0) protocol))) @@ -944,10 +944,10 @@ Returns a list of (host display-number screen protocol)." (defun gc-cleanup () (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) @@ -974,10 +974,10 @@ Returns a list of (host display-number screen protocol)." (defun default-keysym-translate (display state object) (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) + (type card16 state) + (type t object) + (ignore display state) + (clx-values t)) object) @@ -1054,13 +1054,13 @@ Returns a list of (host display-number screen protocol)." (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) - (count 0)) + (count 0)) (dolist (byte (rest bytes)) (setq it - `(dpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) + `(dpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit @@ -1080,8 +1080,8 @@ Returns a list of (host display-number screen protocol)." (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) + (it (first bytes)) + (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the (unsigned-byte ,size) ,byte) @@ -1098,9 +1098,9 @@ Returns a list of (host display-number screen protocol)." ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s (defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + x y width height padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)) @@ -1109,8 +1109,8 @@ Returns a list of (host display-number screen protocol)." ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s (defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsp-first-p)) diff --git a/src/clx/depdefs.lisp b/src/clx/depdefs.lisp index 14d97754d..18a6ff001 100644 --- a/src/clx/depdefs.lisp +++ b/src/clx/depdefs.lisp @@ -3,9 +3,9 @@ ;; This file contains some of the system dependent code for CLX ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -31,8 +31,8 @@ (progn (defun rational (x) (if (rationalp x) - x - (lisp:rational x))) + x + (lisp:rational x))) (deftype rational (&optional l u) `(lisp:rational ,l ,u))) ;;; DECLAIM @@ -41,8 +41,8 @@ (defmacro declaim (&rest decl-specs) (if (cdr decl-specs) `(progn - ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) - decl-specs)) + ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) + decl-specs)) `(proclaim ',(car decl-specs)))) ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. @@ -121,7 +121,7 @@ '(drawable window pixmap - ;; gcontext + ;; gcontext cursor colormap font)) @@ -129,7 +129,7 @@ (defmacro resource-id-map-test () #+excl '#'equal #-excl '#'eql) - ; (eq fixnum fixnum) is not guaranteed. + ; (eq fixnum fixnum) is not guaranteed. (defmacro atom-cache-map-test () #+excl '#'equal #-excl '#'eq) @@ -222,18 +222,18 @@ (defun make-index-op (operator args) `(the array-index - (values - ,(case (length args) - (0 `(,operator)) - (1 `(,operator - ,(make-index-typed (first args)))) - (2 `(,operator - ,(make-index-typed (first args)) - ,(make-index-typed (second args)))) - (otherwise - `(,operator - ,(make-index-op operator (subseq args 0 (1- (length args)))) - ,(make-index-typed (first (last args))))))))) + (values + ,(case (length args) + (0 `(,operator)) + (1 `(,operator + ,(make-index-typed (first args)))) + (2 `(,operator + ,(make-index-typed (first args)) + ,(make-index-typed (second args)))) + (otherwise + `(,operator + ,(make-index-op operator (subseq args 0 (1- (length args)))) + ,(make-index-typed (first (last args))))))))) (defmacro index+ (&rest numbers) (make-index-op '+ numbers)) (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) @@ -309,34 +309,34 @@ (defmacro index-floor (number divisor) (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(floor ,number ,divisor)))) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(floor ,number ,divisor)))) (defmacro index-ceiling (number divisor) (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) - `(si:%fixnum-ceiling ,number ,divisor)) - (t `(ceiling ,number ,divisor)))) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) + `(si:%fixnum-ceiling ,number ,divisor)) + (t `(ceiling ,number ,divisor)))) (defmacro index-truncate (number divisor) (cond ((eql divisor 1) number) - ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,divisor)) - (t `(truncate ,number ,divisor)))) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(truncate ,number ,divisor)))) (defmacro index-mod (number divisor) (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) - `(si:%fixnum-mod ,number ,divisor)) - (t `(mod ,number ,divisor)))) + `(si:%fixnum-mod ,number ,divisor)) + (t `(mod ,number ,divisor)))) (defmacro index-ash (number count) (cond ((eql count 0) number) - ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) - `(si:%fixnum-floor ,number ,(expt 2 (- count)))) - ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) - `(si:%fixnum-multiply ,number ,(expt 2 count))) - (t `(ash ,number ,count)))) + ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,(expt 2 (- count)))) + ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) + `(si:%fixnum-multiply ,number ,(expt 2 count))) + (t `(ash ,number ,count)))) (defmacro index-plusp (number) `(plusp ,number)) (defmacro index-zerop (number) `(zerop ,number)) @@ -370,8 +370,8 @@ ) (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) - (:copier nil) (:predicate nil)) - (size 0 :type array-index) ;Buffer size + (:copier nil) (:predicate nil)) + (size 0 :type array-index) ;Buffer size ;; Byte (8 bit) input buffer (ibuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) input buffer @@ -418,124 +418,124 @@ used, since NIL is the empty list.") (defmacro def-clx-class ((name &rest options) &body slots) (if (or (not (listp *def-clx-class-use-defclass*)) - (member name *def-clx-class-use-defclass*)) + (member name *def-clx-class-use-defclass*)) (let ((clos-package #+clx-ansi-common-lisp - (find-package :common-lisp) - #-clx-ansi-common-lisp - (or (find-package :clos) - (find-package :pcl) - (let ((lisp-pkg (find-package :lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg)))) - (constructor t) - (constructor-args t) - (include nil) - (print-function nil) - (copier t) - (predicate t)) - (dolist (option options) - (ecase (pop option) - (:constructor - (setf constructor (pop option)) - (setf constructor-args (if (null option) t (pop option)))) - (:include - (setf include (pop option))) - (:print-function - (setf print-function (pop option))) - (:copier - (setf copier (pop option))) - (:predicate - (setf predicate (pop option))))) - (flet ((cintern (&rest symbols) - (intern (apply #'concatenate 'simple-string - (mapcar #'symbol-name symbols)) - *package*)) - (kintern (symbol) - (intern (symbol-name symbol) (find-package :keyword))) - (closintern (symbol) - (intern (symbol-name symbol) clos-package))) - (when (eq constructor t) - (setf constructor (cintern 'make- name))) - (when (eq copier t) - (setf copier (cintern 'copy- name))) - (when (eq predicate t) - (setf predicate (cintern name '-p))) - (when include - (setf slots (append (get include 'def-clx-class) slots))) - (let* ((n-slots (length slots)) - (slot-names (make-list n-slots)) - (slot-initforms (make-list n-slots)) - (slot-types (make-list n-slots))) - (dotimes (i n-slots) - (let ((slot (elt slots i))) - (setf (elt slot-names i) (pop slot)) - (setf (elt slot-initforms i) (pop slot)) - (setf (elt slot-types i) (getf slot :type t)))) - `(progn + (find-package :common-lisp) + #-clx-ansi-common-lisp + (or (find-package :clos) + (find-package :pcl) + (let ((lisp-pkg (find-package :lisp))) + (and (find-symbol (string 'defclass) lisp-pkg) + lisp-pkg)))) + (constructor t) + (constructor-args t) + (include nil) + (print-function nil) + (copier t) + (predicate t)) + (dolist (option options) + (ecase (pop option) + (:constructor + (setf constructor (pop option)) + (setf constructor-args (if (null option) t (pop option)))) + (:include + (setf include (pop option))) + (:print-function + (setf print-function (pop option))) + (:copier + (setf copier (pop option))) + (:predicate + (setf predicate (pop option))))) + (flet ((cintern (&rest symbols) + (intern (apply #'concatenate 'simple-string + (mapcar #'symbol-name symbols)) + *package*)) + (kintern (symbol) + (intern (symbol-name symbol) (find-package :keyword))) + (closintern (symbol) + (intern (symbol-name symbol) clos-package))) + (when (eq constructor t) + (setf constructor (cintern 'make- name))) + (when (eq copier t) + (setf copier (cintern 'copy- name))) + (when (eq predicate t) + (setf predicate (cintern name '-p))) + (when include + (setf slots (append (get include 'def-clx-class) slots))) + (let* ((n-slots (length slots)) + (slot-names (make-list n-slots)) + (slot-initforms (make-list n-slots)) + (slot-types (make-list n-slots))) + (dotimes (i n-slots) + (let ((slot (elt slots i))) + (setf (elt slot-names i) (pop slot)) + (setf (elt slot-initforms i) (pop slot)) + (setf (elt slot-types i) (getf slot :type t)))) + `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'def-clx-class) ',slots)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',name 'def-clx-class) ',slots)) - ;; From here down are the system-specific expansions: + ;; From here down are the system-specific expansions: - (within-definition (,name def-clx-class) - (,(closintern 'defclass) - ,name ,(and include `(,include)) - (,@(map 'list - #'(lambda (slot-name slot-initform slot-type) - `(,slot-name - :initform ,slot-initform :type ,slot-type - :accessor ,(cintern name '- slot-name) - ,@(when (and constructor - (or (eq constructor-args t) - (member slot-name - constructor-args))) - `(:initarg ,(kintern slot-name))) - )) - slot-names slot-initforms slot-types))) - ,(when constructor - (if (eq constructor-args t) - `(defun ,constructor (&rest args) - (apply #',(closintern 'make-instance) - ',name args)) - `(defun ,constructor ,constructor-args - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - (and (member slot-name slot-names) - `(,(kintern slot-name) ,slot-name))) - constructor-args))))) - ,(when predicate - #+allegro - `(progn - (,(closintern 'defmethod) ,predicate (object) - (declare (ignore object)) - nil) - (,(closintern 'defmethod) ,predicate ((object ,name)) - t)) - #-allegro - `(defun ,predicate (object) - (typep object ',name))) - ,(when copier - `(,(closintern 'defmethod) ,copier ((.object. ,name)) - (,(closintern 'with-slots) ,slot-names .object. - (,(closintern 'make-instance) ',name - ,@(mapcan #'(lambda (slot-name) - `(,(kintern slot-name) ,slot-name)) - slot-names))))) - ,(when print-function - `(,(closintern 'defmethod) - ,(closintern 'print-object) - ((object ,name) stream) - (,print-function object stream 0)))))))) + (within-definition (,name def-clx-class) + (,(closintern 'defclass) + ,name ,(and include `(,include)) + (,@(map 'list + #'(lambda (slot-name slot-initform slot-type) + `(,slot-name + :initform ,slot-initform :type ,slot-type + :accessor ,(cintern name '- slot-name) + ,@(when (and constructor + (or (eq constructor-args t) + (member slot-name + constructor-args))) + `(:initarg ,(kintern slot-name))) + )) + slot-names slot-initforms slot-types))) + ,(when constructor + (if (eq constructor-args t) + `(defun ,constructor (&rest args) + (apply #',(closintern 'make-instance) + ',name args)) + `(defun ,constructor ,constructor-args + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + (and (member slot-name slot-names) + `(,(kintern slot-name) ,slot-name))) + constructor-args))))) + ,(when predicate + #+allegro + `(progn + (,(closintern 'defmethod) ,predicate (object) + (declare (ignore object)) + nil) + (,(closintern 'defmethod) ,predicate ((object ,name)) + t)) + #-allegro + `(defun ,predicate (object) + (typep object ',name))) + ,(when copier + `(,(closintern 'defmethod) ,copier ((.object. ,name)) + (,(closintern 'with-slots) ,slot-names .object. + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + `(,(kintern slot-name) ,slot-name)) + slot-names))))) + ,(when print-function + `(,(closintern 'defmethod) + ,(closintern 'print-object) + ((object ,name) stream) + (,print-function object stream 0)))))))) `(within-definition (,name def-clx-class) - (defstruct (,name ,@options) - ,@slots)))) + (defstruct (,name ,@options) + ,@slots)))) #+Genera (progn (scl:defprop def-clx-class "CLX Class" si:definition-type-name) (scl:defprop def-clx-class zwei:defselect-function-spec-finder - zwei:definition-function-spec-finder)) + zwei:definition-function-spec-finder)) ;; We need this here so we can define DISPLAY for CLX. @@ -601,20 +601,20 @@ used, since NIL is the empty list.") #-(or clx-ansi-common-lisp Genera) (defun print-unreadable-object-function (object stream type identity function) (declare #+lispm - (sys:downward-funarg function)) + (sys:downward-funarg function)) (princ "#<" stream) (when type (let ((type (type-of object)) - (pcl-package (find-package :pcl))) + (pcl-package (find-package :pcl))) ;; Handle pcl type-of lossage (when (and pcl-package - (symbolp type) - (eq (symbol-package type) pcl-package) - (string-equal (symbol-name type) "STD-INSTANCE")) - (setq type - (funcall (intern (symbol-name 'class-name) pcl-package) - (funcall (intern (symbol-name 'class-of) pcl-package) - object)))) + (symbolp type) + (eq (symbol-package type) pcl-package) + (string-equal (symbol-name type) "STD-INSTANCE")) + (setq type + (funcall (intern (symbol-name 'class-name) pcl-package) + (funcall (intern (symbol-name 'class-of) pcl-package) + object)))) (prin1 type stream))) (when (and type function) (princ " " stream)) (when function (funcall function)) @@ -625,11 +625,11 @@ used, since NIL is the empty list.") #-(or clx-ansi-common-lisp Genera) (defmacro print-unreadable-object - ((object stream &key type identity) &body body) + ((object stream &key type identity) &body body) (if body `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) + (print-unreadable-object-function + ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) @@ -638,12 +638,12 @@ used, since NIL is the empty list.") ;;----------------------------------------------------------------------------- (defconstant +image-bit-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) + #+clx-little-endian t + #-clx-little-endian nil) (defconstant +image-byte-lsb-first-p+ - #+clx-little-endian t - #-clx-little-endian nil) + #+clx-little-endian t + #-clx-little-endian nil) (defconstant +image-unit+ 32) @@ -686,8 +686,8 @@ used, since NIL is the empty list.") "Return the name of the unix domain socket for host and display, or nil if a network socket should be opened." (cond ((or (string= host "") (string= host "unix")) - (format nil "~A~D" +X-unix-socket-path+ display)) - #+darwin - ((and (> (length host) 10) (string= host "tmp/launch" :end1 10)) - (format nil "/~A:~D" host display)) - (t nil))) + (format nil "~A~D" +X-unix-socket-path+ display)) + #+darwin + ((and (> (length host) 10) (string= host "tmp/launch" :end1 10)) + (format nil "/~A:~D" host display)) + (t nil))) diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp index ba6bdf1cb..7e4166c07 100644 --- a/src/clx/dependent.lisp +++ b/src/clx/dependent.lisp @@ -3,9 +3,9 @@ ;; This file contains some of the system dependent code for CLX ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -67,9 +67,9 @@ "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+)))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals @@ -78,13 +78,13 @@ ;; is 0. (defun declare-buffun () `(declare (optimize - (speed ,+buffer-speed+) - (safety ,+buffer-safety+) - (debug ,+buffer-debug+))))) + (speed ,+buffer-speed+) + (safety ,+buffer-safety+) + (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 - card16->int16 int16->card16 - card32->int32 int32->card32)) + card16->int16 int16->card16 + card32->int32 int32->card32)) #-Genera (progn @@ -94,8 +94,8 @@ (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) - (the int8 (- x #x100)) - x))) + (the int8 (- x #x100)) + x))) (defun int8->card8 (x) (declare (type int8 x)) @@ -108,8 +108,8 @@ (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) - (the int16 (- x #x10000)) - x))) + (the int16 (- x #x10000)) + x))) (defun int16->card16 (x) (declare (type int16 x)) @@ -122,8 +122,8 @@ (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) - (the int32 (- x #x100000000)) - x))) + (the int32 (- x #x100000000)) + x))) (defun int32->card32 (x) (declare (type int32 x)) @@ -169,29 +169,29 @@ (defun aref-card8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) @@ -216,7 +216,7 @@ #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 - aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays Genera) (progn @@ -295,115 +295,115 @@ (defun aref-card8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte))) + :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-byte) v)) + :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte))) + :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-byte) v)) + :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word))) + :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-word) v)) + :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word))) + :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-word) v)) + :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) + :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) + :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long))) + :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :signed-long) v)) + :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long))) + :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i - :unsigned-long) v)) + :unsigned-long) v)) ) @@ -412,99 +412,99 @@ (defun aref-card8 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values card8)) + (type array-index i) + (clx-values card8)) #.(declare-buffun) (the card8 (lucid::%svref-8bit a i))) (defun aset-card8 (v a i) (declare (type card8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-8bit a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values int8)) + (type array-index i) + (clx-values int8)) #.(declare-buffun) (the int8 (lucid::%svref-signed-8bit a i))) (defun aset-int8 (v a i) (declare (type int8 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-8bit a i) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values card16)) + (type array-index i) + (clx-values card16)) #.(declare-buffun) (the card16 (lucid::%svref-16bit a (index-ash i -1)))) (defun aset-card16 (v a i) (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-16bit a (index-ash i -1)) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values int16)) + (type array-index i) + (clx-values int16)) #.(declare-buffun) (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) (defun aset-int16 (v a i) (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values card32)) + (type array-index i) + (clx-values card32)) #.(declare-buffun) (the card32 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card32 (v a i) (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values int32)) + (type array-index i) + (clx-values int32)) #.(declare-buffun) (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) (defun aset-int32 (v a i) (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) - (type array-index i) - (clx-values card29)) + (type array-index i) + (clx-values card29)) #.(declare-buffun) (the card29 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card29 (v a i) (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) @@ -517,120 +517,120 @@ (defun aref-card16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 - (ash (the card8 (aref a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) + (ash (the card8 (aref a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 - (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) - (the card8 - (aref a (index+ i +word-0+)))))) + (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) + (the card8 + (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 - (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) - (type array-index i)) + (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 - (ash (the card8 (aref a (index+ i +long-3+))) 24)) - (the card29 - (ash (the card8 (aref a (index+ i +long-2+))) 16)) - (the card16 - (ash (the card8 (aref a (index+ i +long-1+))) 8)) - (the card8 - (aref a (index+ i +long-0+)))))) + (ash (the card8 (aref a (index+ i +long-3+))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i +long-2+))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i +long-1+))) 8)) + (the card8 + (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) - (type buffer-bytes a) - (type array-index i)) + (type buffer-bytes a) + (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) - (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) - (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) - (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) + (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) @@ -719,146 +719,146 @@ (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () - (let ((alist - `(#-lispm - ;; The normal ascii codes for the control characters. - ,@`((#\Return . 13) - (#\Linefeed . 10) - (#\Rubout . 127) - (#\Page . 12) - (#\Tab . 9) - (#\Backspace . 8) - (#\Newline . 10) - (#\Space . 32)) - ;; One the lispm, #\Newline is #\Return, but we'd really like - ;; #\Newline to translate to ascii code 10, so we swap the - ;; Ascii codes for #\Return and #\Linefeed. We also provide - ;; mappings from the counterparts of these control characters - ;; so that the character mapping from the lisp machine - ;; character set to ascii is invertible. - #+lispm - ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) - (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) - (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) - (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) - (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) - (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) - (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) - (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) - ;; The rest of the common lisp charater set with the normal - ;; ascii codes for them. - (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) - (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) - (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) - (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) - (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) - (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) - (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) - (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) - (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) - (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) - (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) - (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) - (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) - (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) - (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) - (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) - (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) - (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) - (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) - (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) - (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) - (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) - (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) - (#\} . 125) (#\~ . 126)))) - (cond ((dolist (pair alist nil) - (when (not (= (char-code (car pair)) (cdr pair))) - (return t))) - `(progn - (defconstant *char-to-card8-translation-table* - ',(let ((array (make-array - (let ((max-char-code 255)) - (dolist (pair alist) - (setq max-char-code - (max max-char-code - (char-code (car pair))))) - (1+ max-char-code)) - :element-type 'card8))) - (dotimes (i (length array)) - (setf (aref array i) (mod i 256))) - (dolist (pair alist) - (setf (aref array (char-code (car pair))) - (cdr pair))) - array)) - (defconstant *card8-to-char-translation-table* - ',(let ((array (make-array 256))) - (dotimes (i (length array)) - (setf (aref array i) (code-char i))) - (dolist (pair alist) - (setf (aref array (cdr pair)) (car pair))) - array)) - #-Genera - (progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (aref (the (simple-array card8 (*)) - *char-to-card8-translation-table*) - (the array-index (char-code char))))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char - (or (aref (the simple-vector *card8-to-char-translation-table*) - card8) - (error "Invalid CHAR code ~D." card8)))) - ) - #+Genera - (progn - (defun char->card8 (char) - (declare lt:(side-effects reader reducible)) - (aref *char-to-card8-translation-table* (char-code char))) - (defun card8->char (card8) - (declare lt:(side-effects reader reducible)) - (aref *card8-to-char-translation-table* card8)) - ) - #-Minima - (dotimes (i 256) - (unless (= i (char->card8 (card8->char i))) - (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" - (list i - (card8->char i) - (char->card8 (card8->char i)))) - (return nil))) - #-Minima - (dotimes (i (length *char-to-card8-translation-table*)) - (let ((char (code-char i))) - (unless (eql char (card8->char (char->card8 char))) - (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" - (list char - (char->card8 char) - (card8->char (char->card8 char)))) - (return nil)))))) - (t - `(progn - (defun char->card8 (char) - (declare (type base-char char)) - #.(declare-buffun) - (the card8 (char-code char))) - (defun card8->char (card8) - (declare (type card8 card8)) - #.(declare-buffun) - (the base-char (code-char card8))) - )))))) + (let ((alist + `(#-lispm + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) + ;; The rest of the common lisp charater set with the normal + ;; ascii codes for them. + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-array 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + #-Genera + (progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char + (or (aref (the simple-vector *card8-to-char-translation-table*) + card8) + (error "Invalid CHAR code ~D." card8)))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + #-Minima + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + #-Minima + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type base-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the base-char (code-char card8))) + )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; -;; Common-Lisp doesn't provide process locking primitives, so we define -;; our own here, based on Zetalisp primitives. Holding-Lock is very -;; similar to with-lock on The TI Explorer, and a little more efficient -;; than with-process-lock on a Symbolics. +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. @@ -920,12 +920,12 @@ ;;; #+(and CMU (not mp)) (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) `(let #+cmu((ext:*gc-verbose* nil) - (ext:*gc-inhibit-hook* nil) - (ext:*before-gc-hooks* nil) - (ext:*after-gc-hooks* nil)) - #+sbcl() + (ext:*gc-inhibit-hook* nil) + (ext:*before-gc-hooks* nil) + (ext:*after-gc-hooks* nil)) + #+sbcl() ,locator ,display ,whostate ,timeout (system:without-interrupts (progn ,@body)))) @@ -933,8 +933,8 @@ ;;; #+(and cmu mp) (defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) + &key timeout) + &body body) (declare (ignore display)) `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) ,@body)) @@ -949,16 +949,16 @@ #+(and ecl threads) (defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) + &key timeout) + &body body) (declare (ignore display)) `(mp::with-lock (,lock) ,@body)) #+sbcl (defmacro holding-lock ((lock display &optional (whostate "CLX wait") - &key timeout) - &body body) + &key timeout) + &body body) ;; This macro is used by WITH-DISPLAY, which claims to be callable ;; recursively. So, had better use a recursive lock. ;; @@ -967,125 +967,125 @@ (declare (ignore display whostate)) (if timeout `(if ,timeout - (handler-case - (sb-ext:with-timeout ,timeout - (sb-thread:with-recursive-lock (,lock) - ,@body)) - (sb-ext:timeout () nil)) - (sb-thread:with-recursive-lock (,lock) - ,@body)) + (handler-case + (sb-ext:with-timeout ,timeout + (sb-thread:with-recursive-lock (,lock) + ,@body)) + (sb-ext:timeout () nil)) + (sb-thread:with-recursive-lock (,lock) + ,@body)) `(sb-thread:with-recursive-lock (,lock) - ,@body))) + ,@body))) #+Genera (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore whostate)) `(process:with-lock (,locator :timeout ,timeout) (let ((.debug-io. (buffer-debug-io ,display))) (scl:let-if .debug-io. ((*debug-io* .debug-io.)) - ,@body)))) + ,@body)))) #+(and lispm (not Genera)) (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore display)) ;; This macro is for use in a multi-process environment. (let ((lock (gensym)) - (have-lock (gensym)) - (timeo (gensym))) + (have-lock (gensym)) + (timeo (gensym))) `(let* ((,lock (zl:locf (svref ,locator 0))) - (,have-lock (eq (car ,lock) sys:current-process)) - (,timeo ,timeout)) + (,have-lock (eq (car ,lock) sys:current-process)) + (,timeo ,timeout)) (unwind-protect - (when (cond (,have-lock) - ((#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock nil sys:current-process)) - ((null ,timeo) - (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) - ((sys:process-wait-with-timeout - ,(or whostate "CLX Lock") (round (* ,timeo 60.)) - #'(lambda (lock process) - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - lock nil process)) - ,lock sys:current-process))) - ,@body) - (unless ,have-lock - (#+explorer si:%store-conditional - #-explorer sys:store-conditional - ,lock sys:current-process nil)))))) + (when (cond (,have-lock) + ((#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock nil sys:current-process)) + ((null ,timeo) + (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) + ((sys:process-wait-with-timeout + ,(or whostate "CLX Lock") (round (* ,timeo 60.)) + #'(lambda (lock process) + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + lock nil process)) + ,lock sys:current-process))) + ,@body) + (unless ,have-lock + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock sys:current-process nil)))))) ;; Lucid has a process locking mechanism as well under release 3.0 #+lcl3.0 (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore display)) (if timeout ;; Hair to support timeout. `(let ((.have-lock. (eq ,locator lcl:*current-process*)) - (.timeout. ,timeout)) - (unwind-protect - (when (cond (.have-lock.) - ((conditional-store ,locator nil lcl:*current-process*)) - ((null .timeout.) - (lcl:process-lock ,locator) - t) - ((lcl:process-wait-with-timeout ,whostate .timeout. - #'(lambda () - (conditional-store ,locator nil lcl:*current-process*)))) - ;; abort the PROCESS-UNLOCK if actually timing out - (t - (setf .have-lock. :abort) - nil)) - ,@body) - (unless .have-lock. - (lcl:process-unlock ,locator)))) + (.timeout. ,timeout)) + (unwind-protect + (when (cond (.have-lock.) + ((conditional-store ,locator nil lcl:*current-process*)) + ((null .timeout.) + (lcl:process-lock ,locator) + t) + ((lcl:process-wait-with-timeout ,whostate .timeout. + #'(lambda () + (conditional-store ,locator nil lcl:*current-process*)))) + ;; abort the PROCESS-UNLOCK if actually timing out + (t + (setf .have-lock. :abort) + nil)) + ,@body) + (unless .have-lock. + (lcl:process-unlock ,locator)))) `(lcl:with-process-lock (,locator) ,@body))) #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) - &body body) + &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect - (block .hl-doit. - (when mp::*scheduler-stack-group* ; fast test for scheduler running - (setq .hl-lock. ,locator - .hl-curproc. mp::*current-process*) - (when (and .hl-curproc. ; nil if in process-wait fun - (not (eq (mp::process-lock-locker .hl-lock.) - .hl-curproc.))) - ;; Then we need to grab the lock. - ,(if timeout - `(if (not (mp::process-lock .hl-lock. .hl-curproc. - ,whostate ,timeout)) - (return-from .hl-doit. nil)) - `(mp::process-lock .hl-lock. .hl-curproc. - ,@(when whostate `(,whostate)))) - ;; There is an apparent race condition here. However, there is - ;; no actual race condition -- our implementation of mp:process- - ;; lock guarantees that the lock will still be held when it - ;; returns, and no interrupt can happen between that and the - ;; execution of the next form. -- jdi 2/27/91 - (setq .hl-obtained-lock. t))) - ,@body) + (block .hl-doit. + (when mp::*scheduler-stack-group* ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + ;; There is an apparent race condition here. However, there is + ;; no actual race condition -- our implementation of mp:process- + ;; lock guarantees that the lock will still be held when it + ;; returns, and no interrupt can happen between that and the + ;; execution of the next form. -- jdi 2/27/91 + (setq .hl-obtained-lock. t))) + ,@body) (if (and .hl-obtained-lock. - ;; Note -- next form added to allow error handler inside - ;; body to unlock the lock prematurely if it knows that - ;; the current process cannot possibly continue but will - ;; throw out (or is it throw up?). - (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) - (mp::process-unlock .hl-lock. .hl-curproc.))))) + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) #+Minima (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) `(holding-lock-1 #'(lambda () ,@body) ,locator ,display - ,@(and whostate `(:whostate ,whostate)) - ,@(and timeout `(:timeout ,timeout)))) + ,@(and whostate `(:whostate ,whostate)) + ,@(and timeout `(:timeout ,timeout)))) #+Minima (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) @@ -1131,19 +1131,19 @@ #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #-clx-ansi-common-lisp + (sys:downward-funarg predicate)) (apply #'process:block-process whostate predicate predicate-args)) #+(and lispm (not Genera)) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #-clx-ansi-common-lisp + (sys:downward-funarg predicate)) (apply #'global:process-wait whostate predicate predicate-args)) #+excl @@ -1151,7 +1151,7 @@ (if mp::*scheduler-stack-group* (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) - (error "Program tried to wait with no scheduler.")))) + (error "Program tried to wait with no scheduler.")))) #+lcl3.0 (defun process-block (whostate predicate &rest predicate-args) @@ -1161,14 +1161,14 @@ #+Minima (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - (dynamic-extent predicate)) + (dynamic-extent predicate)) (apply #'minima:process-wait whostate predicate predicate-args)) #+(and cmu mp) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate)) (mp:process-wait whostate #'(lambda () - (apply predicate predicate-args)))) + (apply predicate predicate-args)))) #+(and sbcl sb-thread) (progn @@ -1209,24 +1209,24 @@ (declare (ignore whostate)) (declare (type function predicate)) (let* ((pid (sb-thread:current-thread-id)) - (last (gethash pid *process-conditions*)) - (lock - (or (car last) - (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) - (queue - (or (cdr last) - (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) + (last (gethash pid *process-conditions*)) + (lock + (or (car last) + (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) + (queue + (or (cdr last) + (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) (unless last (setf (gethash pid *process-conditions*) (cons lock queue))) (sb-thread:with-mutex (lock) (loop (when (apply predicate predicate-args) (return)) (handler-case - (sb-ext:with-timeout .5 - (sb-thread:condition-wait queue lock)) - (sb-ext:timeout () - (format *trace-output* "thread ~A, process-block timed out~%" - (sb-thread:current-thread-id) ))))))) + (sb-ext:with-timeout .5 + (sb-thread:condition-wait queue lock)) + (sb-ext:timeout () + (format *trace-output* "thread ~A, process-block timed out~%" + (sb-thread:current-thread-id) ))))))) ;;; PROCESS-WAKEUP: Check some other process' wait function. @@ -1242,11 +1242,11 @@ (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) - (error "~s is not a process" curproc)) + (error "~s is not a process" curproc)) (unless (mp::process-p process) - (error "~s is not a process" process)) + (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) - (mp::process-allow-schedule process))))) + (mp::process-allow-schedule process))))) #+Genera (defun process-wakeup (process) @@ -1277,7 +1277,7 @@ (declare (ignore process)) (destructuring-bind (lock . queue) (gethash (sb-thread:current-thread-id) *process-conditions* - (cons nil nil)) + (cons nil nil)) (declare (ignore lock)) (when queue (sb-thread:condition-notify queue)))) @@ -1365,8 +1365,8 @@ (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t)))) + (setf ,place ,new-value) + t)))) #+sbcl (progn @@ -1375,13 +1375,13 @@ (defmacro conditional-store (place old-value new-value) `(sb-thread:with-mutex (*conditional-store-lock*) (cond ((eq ,place ,old-value) - (setf ,place ,new-value) - t))))) + (setf ,place ,new-value) + t))))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery -;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. -;;; It prevents multiple mindless errors when the network craters. +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- @@ -1397,16 +1397,16 @@ `(let ((.buffer. ,buffer)) (unless (buffer-dead .buffer.) (scl:condition-bind - (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) - ,@body)))) + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body)))) #-Genera (defmacro wrap-buf-input ((buffer) &body body) @@ -1420,21 +1420,21 @@ `(let ((.buffer. ,buffer)) (scl:condition-bind (((sys:network-error) - #'(lambda (error) - (scl:condition-case () - (funcall (buffer-close-function .buffer.) .buffer. :abort t) - (sys:network-error)) - (setf (buffer-dead .buffer.) error) - (setf (buffer-output-stream .buffer.) nil) - (setf (buffer-input-stream .buffer.) nil) - nil))) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) ,@body))) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives -;;; Functions for opening, reading writing forcing-output and closing -;;; the stream to the server. +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X @@ -1494,32 +1494,32 @@ (defun open-x-stream (host display protocol) (let ((host (net:parse-host host))) (if (or protocol (plusp display)) - ;; The protocol was specified or the display isn't 0, so we - ;; can't use the Generic Network System. If the protocol was - ;; specified, then use that protocol, otherwise, blindly use - ;; TCP. - (ccase protocol - ((:tcp nil) - (tcp:open-tcp-stream - host (+ *x-tcp-port* display) nil - :direction :io - :characters nil - :ascii-translation nil)) - ((:dna) - (dna:open-dna-bidirectional-stream - host (format nil "X$X~D" display) - :characters nil - :ascii-translation nil))) + ;; The protocol was specified or the display isn't 0, so we + ;; can't use the Generic Network System. If the protocol was + ;; specified, then use that protocol, otherwise, blindly use + ;; TCP. + (ccase protocol + ((:tcp nil) + (tcp:open-tcp-stream + host (+ *x-tcp-port* display) nil + :direction :io + :characters nil + :ascii-translation nil)) + ((:dna) + (dna:open-dna-bidirectional-stream + host (format nil "X$X~D" display) + :characters nil + :ascii-translation nil))) (let ((neti:*invoke-service-automatic-retry* t)) - (net:invoke-service-on-host :x-window-system host))))) + (net:invoke-service-on-host :x-window-system host))))) #+explorer (defun open-x-stream (host display protocol) (declare (ignore protocol)) (net:open-connection-on-medium - (net:parse-host host) ;Host - :byte-stream ;Medium - "X11" ;Logical contact name + (net:parse-host host) ;Host + :byte-stream ;Medium + "X11" ;Logical contact name :stream-type :character-stream :direction :bidirectional :timeout-after-open nil @@ -1540,16 +1540,16 @@ (when (minusp fd) (error "Failed to connect to server: ~A ~D" host display)) (user::make-lisp-stream :input-handle fd - :output-handle fd - :element-type 'unsigned-byte - #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) + :output-handle fd + :element-type 'unsigned-byte + #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) #+(or kcl ibcl) (defun open-x-stream (host display protocol) protocol ;; unused (let ((stream (open-socket-stream host display))) (if (streamp stream) - stream + stream (error "Cannot connect to server: ~A:~D" host display)))) #+excl @@ -1568,8 +1568,8 @@ (defun open-x-stream (host display protocol) (declare (ignore protocol));; unused (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address - (cdr (host-address host))) - :foreign-port (+ *x-tcp-port* display))) + (cdr (host-address host))) + :foreign-port (+ *x-tcp-port* display))) #+(or sbcl ecl) (defun open-x-stream (host display protocol) @@ -1579,13 +1579,13 @@ (socket-make-stream (if local-socket-path (let ((s (make-instance 'local-socket :type :stream))) - (socket-connect s local-socket-path) - s) + (socket-connect s local-socket-path) + s) (let ((host (car (host-ent-addresses (get-host-by-name host))))) - (when host - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (socket-connect s host (+ 6000 display)) - s)))) + (when host + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (socket-connect s host (+ 6000 display)) + s)))) :element-type '(unsigned-byte 8) :input t :output t :buffering :none))) @@ -1596,18 +1596,18 @@ ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) - ((funcall stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (multiple-value-bind (ignore eofp) - (funcall stream :string-in nil vector start end) - eofp)))) + ((funcall stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (multiple-value-bind (ignore eofp) + (funcall stream :string-in nil vector start end) + eofp)))) #+excl @@ -1616,28 +1616,28 @@ ;; (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) - (fd (display-input-stream display))) + (fd (display-input-stream display))) (declare (type array-index howmany) - (fixnum fd)) + (fixnum fd)) (or (cond ((fd-char-avail-p fd) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (fd-read-bytes fd vector start howmany)))) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) #+lcl3.0 (defmacro with-underlying-stream ((variable stream display direction) &body body) `(let ((,variable - (or (getf (display-plist ,display) ',direction) - (setf (getf (display-plist ,display) ',direction) - (lucid::underlying-stream - ,stream ,(if (eq direction 'input) :input :output)))))) + (or (getf (display-plist ,display) ',direction) + (setf (getf (display-plist ,display) ',direction) + (lucid::underlying-stream + ,stream ,(if (eq direction 'input) :input :output)))))) ,@body)) #+lcl3.0 @@ -1649,34 +1649,34 @@ ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:read-array. (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (with-underlying-stream (stream stream display input) - (eq (lcl:read-array stream vector start end nil :eof) :eof))))) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (with-underlying-stream (stream stream display input) + (eq (lcl:read-array stream vector start end nil :eof) :eof))))) #+Minima (defun buffer-read-default (display vector start end timeout) ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (eq :eof (minima:read-vector vector stream nil start end))))) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (eq :eof (minima:read-vector vector stream nil start end))))) ;;; BUFFER-READ-DEFAULT for CMU Common Lisp. ;;; @@ -1687,63 +1687,63 @@ #+(or CMU sbcl) (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (#+cmu system:read-n-bytes - #+sbcl sb-sys:read-n-bytes - (display-input-stream display) - vector start (- end start)) - nil))) + (not (listen (display-input-stream display)))) + :timeout) + (t + (#+cmu system:read-n-bytes + #+sbcl sb-sys:read-n-bytes + (display-input-stream display) + vector start (- end start)) + nil))) #+(or ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null fixnum) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) - (not (listen (display-input-stream display)))) - :timeout) - (t - (read-sequence vector - (display-input-stream display) + (not (listen (display-input-stream display)))) + :timeout) + (t + (read-sequence vector + (display-input-stream display) :start start :end end) - nil))) + nil))) ;;; WARNING: -;;; CLX performance will suffer if your lisp uses read-byte for -;;; receiving all data from the X Window System server. -;;; You are encouraged to write a specialized version of -;;; buffer-read-default that does block transfers. +;;; CLX performance will suffer if your lisp uses read-byte for +;;; receiving all data from the X Window System server. +;;; You are encouraged to write a specialized version of +;;; buffer-read-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) - (type buffer-bytes vector) - (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((buffer-input-wait-default display timeout))) - (do* ((index start (index1+ index))) - ((index>= index end) nil) - (declare (type array-index index)) - (let ((c (read-byte stream nil nil))) - (declare (type (or null card8) c)) - (if (null c) - (return t) - (setf (aref vector index) (the card8 c)))))))) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((buffer-input-wait-default display timeout))) + (do* ((index start (index1+ index))) + ((index>= index end) nil) + (declare (type array-index index)) + (let ((c (read-byte stream nil nil))) + (declare (type (or null card8) c)) + (if (null c) + (return t) + (setf (aref vector index) (the card8 c)))))))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream @@ -1751,8 +1751,8 @@ (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) @@ -1762,11 +1762,11 @@ #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (excl::filesys-write-bytes (display-output-stream display) vector start - (- end start))) + (- end start))) #+lcl3.0 (defun buffer-write-default (vector display start end) @@ -1775,21 +1775,21 @@ ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:write-array. (declare (type display display) - (type buffer-bytes vector) - (type array-index start end)) + (type buffer-bytes vector) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-underlying-stream (stream stream display output) - (lcl:write-array stream vector start end))))) + (lcl:write-array stream vector start end))))) #+Minima (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) @@ -1799,8 +1799,8 @@ #+CMU (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (system:output-raw-bytes (display-output-stream display) vector start end) nil) @@ -1808,33 +1808,33 @@ #+(or sbcl ecl clisp) (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (write-sequence vector (display-output-stream display) :start start :end end) nil) ;;; WARNING: -;;; CLX performance will be severely degraded if your lisp uses -;;; write-byte to send all data to the X Window System server. -;;; You are STRONGLY encouraged to write a specialized version -;;; of buffer-write-default that does block transfers. +;;; CLX performance will be severely degraded if your lisp uses +;;; write-byte to send all data to the X Window System server. +;;; You are STRONGLY encouraged to write a specialized version +;;; of buffer-write-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp ecl) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) + (type display display) + (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-vector (vector buffer-bytes) - (do ((index start (index1+ index))) - ((index>= index end)) - (declare (type array-index index)) - (write-byte (aref vector index) stream)))))) + (do ((index start (index1+ index))) + ((index>= index end)) + (declare (type array-index index)) + (write-byte (aref vector index) stream)))))) ;;; buffer-force-output-default - force output to the X stream @@ -1858,7 +1858,7 @@ (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display) - (ignore abort)) + (ignore abort)) #.(declare-buffun) (excl::filesys-checking-close (display-output-stream display))) @@ -1886,85 +1886,85 @@ #-(or Genera explorer excl lcl3.0 CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout))))) #+(or CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null number) timeout)) + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((listen stream) nil) - ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) + ((listen stream) nil) + ((eql timeout 0) :timeout) + (t + (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) + :input timeout) + #+mp (mp:process-wait-until-fd-usable + (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) (ext:socket-status stream (and timeout sec) (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) + #-(or sbcl mp clisp) (system:wait-until-fd-usable + (system:fd-stream-fd stream) :input timeout) + nil + :timeout))))) #+Genera (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((scl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) (si:stream-input-block stream "CLX Input")) - (t - (scl:condition-bind ((neti:protocol-timeout - #'(lambda (error) - (when (eq stream (scl:send error :stream)) - (return-from buffer-input-wait-default :timeout))))) - (neti:with-stream-timeout (stream :input timeout) - (si:stream-input-block stream "CLX Input"))))) + ((scl:send stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((null timeout) (si:stream-input-block stream "CLX Input")) + (t + (scl:condition-bind ((neti:protocol-timeout + #'(lambda (error) + (when (eq stream (scl:send error :stream)) + (return-from buffer-input-wait-default :timeout))))) + (neti:with-stream-timeout (stream :input timeout) + (si:stream-input-block stream "CLX Input"))))) nil)) #+explorer (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((zl:send stream :listen) nil) - ((and timeout (= timeout 0)) :timeout) - ((null timeout) - (si:process-wait "CLX Input" stream :listen)) - (t - (unless (si:process-wait-with-timeout - "CLX Input" (round (* timeout 60.)) stream :listen) - (return-from buffer-input-wait-default :timeout)))) + ((zl:send stream :listen) nil) + ((and timeout (= timeout 0)) :timeout) + ((null timeout) + (si:process-wait "CLX Input" stream :listen)) + (t + (unless (si:process-wait-with-timeout + "CLX Input" (round (* timeout 60.)) stream :listen) + (return-from buffer-input-wait-default :timeout)))) nil)) #+excl @@ -1981,71 +1981,71 @@ #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (declare (fixnum fd)) (when (>= fd 0) (cond ((fd-char-avail-p fd) - nil) - - ;; Otherwise no bytes were available on the socket - ((and timeout (= timeout 0)) - ;; If there aren't enough and timeout == 0, timeout. - :timeout) - - ;; If the scheduler is running let it do timeouts. - (mp::*scheduler-stack-group* - #+allegro - (if (not - (mp:wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p - :timeout timeout)) - (return-from buffer-input-wait-default :timeout)) - #-allegro - (mp::wait-for-input-available fd :whostate *read-whostate* - :wait-function #'fd-char-avail-p)) - - ;; Otherwise we have to handle timeouts by hand, and call select() - ;; to block until input is available. Note we don't really handle - ;; the interaction of interrupts and (numberp timeout) here. XX - (t - (let ((res 0)) - (declare (fixnum res)) - (with-interrupt-checking-on - (loop - (setq res (fd-wait-for-input fd (if (null timeout) 0 - (truncate timeout)))) - (cond ((plusp res) ; success - (return nil)) - ((eq res 0) ; timeout - (return :timeout)) - ((eq res -1) ; error - (return t)) - ;; Otherwise we got an interrupt -- go around again. - ))))))))) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (= timeout 0)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + (mp::*scheduler-stack-group* + #+allegro + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + #-allegro + (mp::wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p)) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) - + #+lcl3.0 (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout) - (clx-values timeout)) + (type (or null (real 0 *)) timeout) + (clx-values timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) - ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((with-underlying-stream (stream stream display input) - (lucid::waiting-for-input-from-stream stream + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((with-underlying-stream (stream stream display input) + (lucid::waiting-for-input-from-stream stream (lucid::with-io-unlocked - (if (null timeout) - (lcl:process-wait "CLX Input" #'listen stream) - (lcl:process-wait-with-timeout - "CLX Input" timeout #'listen stream))))) - nil) - (:timeout)))) + (if (null timeout) + (lcl:process-wait "CLX Input" #'listen stream) + (lcl:process-wait-with-timeout + "CLX Input" timeout #'listen stream))))) + nil) + (:timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the @@ -2058,7 +2058,7 @@ (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) - t + t (listen stream)))) #+excl @@ -2067,7 +2067,7 @@ (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) - t + t (fd-char-avail-p fd)))) @@ -2089,7 +2089,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm @@ -2100,7 +2100,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) @@ -2108,49 +2108,49 @@ #+lispm (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) #+excl (defun buffer-replace (target-sequence source-sequence target-start - target-end &optional (source-start 0)) + target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) - (type array-index target-start target-end source-start) - (optimize (speed 3) (safety 0))) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) - (> target-start source-start)) + (> target-start source-start)) then (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ target-start nelts -1) (1- target-index)) - (source-index (+ source-start nelts -1) (1- source-index))) - ((= target-index (1- target-start)) target-sequence) - (declare (type array-index target-index source-index)) - - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index target-end) (= source-index source-end)) - target-sequence) - (declare (type array-index target-index source-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))))) + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) #+cmu (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) #.(declare-buffun) (kernel:bit-bash-copy buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) + (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) + (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) #+lucid @@ -2158,7 +2158,7 @@ ;;;fact it does not. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) #.(declare-buffun) (let ((end2 (lucid::%simple-8bit-vector-length buf2))) (declare (type array-index end2)) @@ -2168,13 +2168,13 @@ #+(and clx-overlapping-arrays (not (or lispm excl))) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #-(or lispm lucid excl CMU clx-overlapping-arrays) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) - (type array-index start1 end1 start2)) + (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #+ti @@ -2183,23 +2183,23 @@ ((null bindings) (sys:eval-body-as-progn body)) (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) - (sys:*eval (cadar bindings))))) + (sys:*eval (cadar bindings))))) #+ti (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) (let ((bindings (cadr form)) - (body (cddr form))) + (body (cddr form))) `(let () ,@(loop for (accessor value) in bindings - collect `(si:bind (si:locf ,accessor) ,value)) + collect `(si:bind (si:locf ,accessor) ,value)) ,@body))) #+ti (defun (:property with-location-bindings compiler::cw-handler) (exp) (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) - (body (compiler::cw-clause (cddr exp)))) + (body (compiler::cw-clause (cddr exp)))) (and compiler::cw-return-expansion-flag - (list* (first exp) bindlist body)))) + (list* (first exp) bindlist body)))) #+(and lispm (not ti)) (defmacro with-location-bindings (bindings &body body) @@ -2207,40 +2207,40 @@ #+lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) + &body body) ;; don't use svref on LHS because Symbolics didn't define locf for it (let* ((local-state (gensym)) - (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway + (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway (dolist (index indexes) (push `((aref ,local-state ,index) (svref ,saved-state ,index)) - bindings)) + bindings)) `(let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) (unwind-protect - (with-location-bindings ,bindings - ,@body) - (setf (svref ,local-state ,ts-index) 0) - (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) - (deallocate-gcontext-state ,saved-state))))) + (with-location-bindings ,bindings + ,@body) + (setf (svref ,local-state ,ts-index) 0) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) - &body body) + &body body) (let ((local-state (gensym)) - (resets nil)) + (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) - resets)) + resets)) `(unwind-protect - (progn - ,@body) + (progn + ,@body) (let ((,local-state (gcontext-local-state ,gc))) - (declare (type gcontext-state ,local-state)) - ,@resets - (setf (svref ,local-state ,ts-index) 0)) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc - (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- @@ -2300,23 +2300,23 @@ (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type)) - `(typep ,object ',type)) + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type - '((drawable drawable-p) (window window-p) - (pixmap pixmap-p) (cursor cursor-p) - (font font-p) (gcontext gcontext-p) - (colormap colormap-p) (null null) - (integer integerp))))) - (cond (predicate - `(,(second predicate) ,object)) - ((eq type 'generalized-boolean) - 't) ; Everything is a generalized-boolean. - (+type-check?+ - `(locally (declare (optimize safety)) (typep ,object ',type))) - (t - `(typep ,object ',type))))))) + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'generalized-boolean) + 't) ; Everything is a generalized-boolean. + (+type-check?+ + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, @@ -2324,9 +2324,9 @@ (defun x-type-error (object type &optional error-string) (x-error 'x-type-error - :datum object - :expected-type type - :type-string error-string)) + :datum object + :expected-type type + :type-string error-string)) ;;----------------------------------------------------------------------------- @@ -2336,9 +2336,9 @@ ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals - &key asynchronous &allow-other-keys) + &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) - (dynamic-extent key-vals)) + (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous @@ -2352,7 +2352,7 @@ #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (defun x-cerror (proceed-format-string condition &rest keyargs) (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) + :proceed-types proceed-format-string)) #+(and Genera (not clx-ansi-common-lisp)) (defun x-error (condition &rest keyargs) @@ -2388,19 +2388,19 @@ (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) + (warn "Disabled event handling on ~S." disp) + (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) + (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) + (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] @@ -2412,7 +2412,7 @@ `(lcl:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) + slots) ,@args)) #+(and excl (not clx-ansi-common-lisp)) @@ -2420,7 +2420,7 @@ `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) + slots) ,@args)) #+(and CMU (not clx-ansi-common-lisp)) @@ -2428,43 +2428,43 @@ `(common-lisp:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) + slots) ,@args)) #+(and lispm (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &body options) (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) + (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) + (pop options))) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil)) (dolist (item options) (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) `(within-definition (,name define-condition) (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) + :initable-instance-variables + #-Genera + (:accessor-prefix ,conc-name) + #+Genera + (:conc-name ,conc-name) + #-Genera + (:outside-accessible-instance-variables ,@slot-names) + #+Genera + (:readable-instance-variables ,@slot-names)) ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) + `(zl:defmethod #-Genera (,name :report) + #+Genera (dbg:report ,name) (stream) + ,(if (stringp reporter) + `(write-string ,reporter stream) + `(,reporter global:self stream)) + global:self)) (zl:compile-flavor-methods ,name) ,(when documentation - `(setf (documentation name 'type) ,documentation)) + `(setf (documentation name 'type) ,documentation)) ',name))) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) @@ -2472,9 +2472,9 @@ #+(and Genera (not clx-ansi-common-lisp)) (scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) + ((dbg:proceed-types '(:continue)) ; + continue-format-string) + (sys:error) (:initable-instance-variables continue-format-string)) #+(and Genera (not clx-ansi-common-lisp)) @@ -2501,44 +2501,44 @@ (defmacro define-condition (name parent-types &body options) ;; Define a structure that when printed displays an error message (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) + (xintern "." name '-reporter.))) (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) + (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) + (pop options))) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil) + (condition (gensym)) + (stream (gensym)) + (report-function (reporter-for-condition name))) (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) + (ecase (first item) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) + (setq report-function (reporter-for-condition (first parent-types)))) `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) + (defstruct (,name (:conc-name ,(intern conc-name)) + (:print-function condition-print) + (:include ,(first parent-types) + (report-function ',report-function))) + ,@slot-names) + ,(when documentation + `(setf (documentation name 'type) ,documentation)) + ,(when reporter + `(defun ,report-function (,condition ,stream) + ,(if (stringp reporter) + `(write-string ,reporter ,stream) + `(,reporter ,condition ,stream)) + ,condition)) + ',name)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun condition-print (condition stream depth) (declare (type x-error condition) - (type stream stream) - (ignore depth)) + (type stream stream) + (ignore depth)) (if *print-escape* (print-unreadable-object (condition stream :type t)) (funcall (x-error-report-function condition) condition stream)) @@ -2548,7 +2548,7 @@ (defun make-condition (type &rest slot-initializations) (declare (dynamic-extent slot-initializations)) (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) + (symbol-package type)))) (apply make-function slot-initializations))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) @@ -2558,8 +2558,8 @@ (:report (lambda (condition stream) (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) + (type-error-datum condition) + (type-error-expected-type condition))))) ;;----------------------------------------------------------------------------- @@ -2571,7 +2571,7 @@ ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) host family (error "HOST-ADDRESS not implemented yet.")) @@ -2620,99 +2620,99 @@ ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) (let ((addr (ip:get-ip-address host))) (unless addr (error "~s isn't an internet host name" host)) (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr)))) + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr)))) ((:chaos 2) (let ((addr (first (chaos:chaos-addresses host)))) (unless addr (error "~s isn't a chaos host name" host)) (list :chaos - (ldb (byte 8 0) addr) - (ldb (byte 8 8) addr)))))) + (ldb (byte 8 0) addr) + (ldb (byte 8 8) addr)))))) #+Genera (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (setf host (string host)) (let ((net-type (ecase family - ((:internet nil 0) :internet) - ((:DECnet 1) :dna) - ((:chaos 2) :chaos)))) + ((:internet nil 0) :internet) + ((:DECnet 1) :dna) + ((:chaos 2) :chaos)))) (dolist (addr - (sys:send (net:parse-host host) :network-addresses) - (error "~S isn't a valid ~(~A~) host name" host family)) + (sys:send (net:parse-host host) :network-addresses) + (error "~S isn't a valid ~(~A~) host name" host family)) (let ((network (car addr)) - (address (cadr addr))) - (when (sys:send network :network-typep net-type) - (return (ecase family - ((:internet nil 0) - (multiple-value-bind (a b c d) (tcp:explode-internet-address address) - (list :internet a b c d))) - ((:DECnet 1) - (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) - ((:chaos 2) - (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) + (address (cadr addr))) + (when (sys:send network :network-typep net-type) + (return (ecase family + ((:internet nil 0) + (multiple-value-bind (a b c d) (tcp:explode-internet-address address) + (list :internet a b c d))) + ((:DECnet 1) + (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) + ((:chaos 2) + (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) #+Minima (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (etypecase family ((:internet nil 0) (list* :internet - (multiple-value-list - (minima:ip-address-components (minima:parse-ip-address (string host)))))))) + (multiple-value-list + (minima:ip-address-components (minima:parse-ip-address (string host)))))))) #+Allegro (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect - (progn - (setf hostent (ipc::gethostbyname (string host))) - (when (zerop hostent) - (no-host-error)) - (ecase family - ((:internet nil 0) - (unless (= (ipc::hostent-addrtype hostent) 2) - (no-address-error)) - (assert (= (ipc::hostent-length hostent) 4)) - (let ((addr (ipc::hostent-addr hostent))) - (when (or (member comp::.target. - '(:hp :sgi4d :sony :dec3100) - :test #'eq) - (probe-file "/lib/ld.so")) - ;; BSD 4.3 based systems require an extra indirection - (setq addr (si:memref-int addr 0 0 :unsigned-long))) - (list :internet - (si:memref-int addr 0 0 :unsigned-byte) - (si:memref-int addr 1 0 :unsigned-byte) - (si:memref-int addr 2 0 :unsigned-byte) - (si:memref-int addr 3 0 :unsigned-byte)))))) - (ff:free-cstruct hostent))))) + (progn + (setf hostent (ipc::gethostbyname (string host))) + (when (zerop hostent) + (no-host-error)) + (ecase family + ((:internet nil 0) + (unless (= (ipc::hostent-addrtype hostent) 2) + (no-address-error)) + (assert (= (ipc::hostent-length hostent) 4)) + (let ((addr (ipc::hostent-addr hostent))) + (when (or (member comp::.target. + '(:hp :sgi4d :sony :dec3100) + :test #'eq) + (probe-file "/lib/ld.so")) + ;; BSD 4.3 based systems require an extra indirection + (setq addr (si:memref-int addr 0 0 :unsigned-long))) + (list :internet + (si:memref-int addr 0 0 :unsigned-byte) + (si:memref-int addr 1 0 :unsigned-byte) + (si:memref-int addr 2 0 :unsigned-byte) + (si:memref-int addr 3 0 :unsigned-byte)))))) + (ff:free-cstruct hostent))))) ;#+sbcl ;(require :sockets) @@ -2722,52 +2722,52 @@ ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () - (error "Unknown host ~S" host)) - (no-address-error () - (error "Host ~S has no ~S address" host family))) + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host)) - #+mna-sockets(net.sbcl.sockets:look-up-host-entry - (string host)) - #+db-sockets(sockets:get-host-by-name (string host)))) + #+mna-sockets(net.sbcl.sockets:look-up-host-entry + (string host)) + #+db-sockets(sockets:get-host-by-name (string host)))) (when (not hostent) - (no-host-error)) + (no-host-error)) (ecase family - ((:internet nil 0) - #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) - (no-address-error)) - #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) - (no-address-error)) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(unless (sockets:host-ent-address hostent) - (no-address-error)) - (append (list :internet) - #+rwi-sockets - (let ((addr (first (ext::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - #+mna-sockets - (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) - (list (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))) - ;; the following form is for use with SBCL and Daniel - ;; Barlow's socket package - #+db-sockets(coerce (sockets:host-ent-address hostent) - 'list))))))) + ((:internet nil 0) + #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2) + (no-address-error)) + #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2) + (no-address-error)) + ;; the following form is for use with SBCL and Daniel + ;; Barlow's socket package + #+db-sockets(unless (sockets:host-ent-address hostent) + (no-address-error)) + (append (list :internet) + #+rwi-sockets + (let ((addr (first (ext::host-entry-addr-list hostent)))) + (list (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))) + #+mna-sockets + (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent)))) + (list (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))) + ;; the following form is for use with SBCL and Daniel + ;; Barlow's socket package + #+db-sockets(coerce (sockets:host-ent-address hostent) + 'list))))))) #+sbcl (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (let ((hostent (get-host-by-name (string host)))) (ecase family @@ -2779,18 +2779,18 @@ ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () - (error "Unknown host ~S" host))) + (error "Unknown host ~S" host))) (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) (unless addr - (no-host-error)) + (no-host-error)) (list :internet - (ldb (byte 8 24) addr) - (ldb (byte 8 16) addr) - (ldb (byte 8 8) addr) - (ldb (byte 8 0) addr))))) + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))))) #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts (defun get-host (host-object) @@ -2799,17 +2799,17 @@ (declare (type list host-object)) (declare (clx-values string family)) (let* ((family (first host-object)) - (address (ecase family - (:internet - (dpb (second host-object) - (byte 8 24) - (dpb (third host-object) - (byte 8 16) - (dpb (fourth host-object) - (byte 8 8) - (fifth host-object))))) - (:chaos - (dpb (third host-object) (byte 8 8) (second host-object)))))) + (address (ecase family + (:internet + (dpb (second host-object) + (byte 8 24) + (dpb (third host-object) + (byte 8 16) + (dpb (fourth host-object) + (byte 8 8) + (fifth host-object))))) + (:chaos + (dpb (third host-object) (byte 8 8) (second host-object)))))) (when (eq family :internet) (setq family :ip)) (let ((host (si:get-host-from-address address family))) (values (and host (funcall host :name)) family)))) @@ -2823,16 +2823,16 @@ (declare (clx-values string family)) (let ((family (first host-object))) (values (sys:send (net:get-host-from-address - (ecase family - (:internet - (apply #'tcp:build-internet-address (rest host-object))) - ((:chaos :DECnet) - (dpb (third host-object) (byte 8 8) (second host-object)))) - (net:local-network-of-type (if (eq family :DECnet) - :DNA - family))) - :name) - family))) + (ecase family + (:internet + (apply #'tcp:build-internet-address (rest host-object))) + ((:chaos :DECnet) + (dpb (third host-object) (byte 8 8) (second host-object)))) + (net:local-network-of-type (if (eq family :DECnet) + :DNA + family))) + :name) + family))) ;;; This isn't required, but it helps make sense of the results from access-hosts #+Minima @@ -2843,10 +2843,10 @@ (declare (clx-values string family)) (let ((family (first host-object))) (values (ecase family - (:internet - (minima:ip-address-string - (apply #'minima:make-ip-address (rest host-object))))) - family))) + (:internet + (minima:ip-address-string + (apply #'minima:make-ip-address (rest host-object))))) + family))) ;;----------------------------------------------------------------------------- @@ -2914,8 +2914,8 @@ (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) - (and string - (pathname string))) + (and string + (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) @@ -2923,8 +2923,8 @@ (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) - (and xauthority - (pathname xauthority))) + (and xauthority + (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) #+ecl @@ -2951,28 +2951,28 @@ C language bindings Returns a list of (host display-number screen protocol)." (let* ((name (or display-name - (getenv "DISPLAY") - (error "DISPLAY environment variable is not set"))) - (slash-i (or (position #\/ name) -1)) - (colon-i (position #\: name :start (1+ slash-i))) - (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) - (host (subseq name (1+ slash-i) colon-i)) - (dot-i (and colon-i (position #\. name :start colon-i))) - (display (when colon-i - (parse-integer name - :start (if decnet-colon-p - (+ colon-i 2) - (1+ colon-i)) - :end dot-i))) - (screen (when dot-i - (parse-integer name :start (1+ dot-i)))) - (protocol - (cond ((or (string= host "") (string-equal host "unix")) :local) - (decnet-colon-p :decnet) - ((> slash-i -1) (intern - (string-upcase (subseq name 0 slash-i)) - :keyword)) - (t :internet)))) + (getenv "DISPLAY") + (error "DISPLAY environment variable is not set"))) + (slash-i (or (position #\/ name) -1)) + (colon-i (position #\: name :start (1+ slash-i))) + (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) + (host (subseq name (1+ slash-i) colon-i)) + (dot-i (and colon-i (position #\. name :start colon-i))) + (display (when colon-i + (parse-integer name + :start (if decnet-colon-p + (+ colon-i 2) + (1+ colon-i)) + :end dot-i))) + (screen (when dot-i + (parse-integer name :start (1+ dot-i)))) + (protocol + (cond ((or (string= host "") (string-equal host "unix")) :local) + (decnet-colon-p :decnet) + ((> slash-i -1) (intern + (string-upcase (subseq name 0 slash-i)) + :keyword)) + (t :internet)))) (list host (or display 0) (or screen 0) protocol))) @@ -2982,10 +2982,10 @@ Returns a list of (host display-number screen protocol)." (defun gc-cleanup () (declare (special *event-free-list* - *pending-command-free-list* - *reply-buffer-free-lists* - *gcontext-local-state-cache* - *temp-gcontext-cache*)) + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) @@ -3006,23 +3006,23 @@ Returns a list of (host display-number screen protocol)." #-(or clx-ansi-common-lisp Genera CMU sbcl ecl) (defun with-standard-io-syntax-function (function) (declare #+lispm - (sys:downward-funarg function)) + (sys:downward-funarg function)) (let ((*package* (find-package :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-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) + (*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-pretty* nil) + (*print-radix* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-suppress* nil) + #+ticl (ticl:*print-structure* t) + #+lucid (lucid::*print-structure* t)) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl ecl) @@ -3049,33 +3049,33 @@ Returns a list of (host display-number screen protocol)." #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) - (type card16 state) - (type t object) - (clx-values t) - (special left-meta-keysym right-meta-keysym - left-super-keysym right-super-keysym - left-hyper-keysym right-hyper-keysym)) + (type card16 state) + (type t object) + (clx-values t) + (special left-meta-keysym right-meta-keysym + left-super-keysym right-super-keysym + left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) - (state-keysymp display state right-meta-keysym)) + (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) - (state-keysymp display state right-super-keysym)) + (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) - (state-keysymp display state right-hyper-keysym)) + (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) #+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) (defun default-keysym-translate (display state object) (declare (type display display) - (type card16 state) - (type t object) - (ignore display state) - (clx-values t)) + (type card16 state) + (type t object) + (ignore display state) + (clx-values t)) object) @@ -3137,31 +3137,31 @@ Returns a list of (host display-number screen protocol)." #+Genera (defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) + ((variable element-type pixarray) &body body) (let ((bits-per-element - (sys:array-bits-per-element - (symbol-value (sys:type-array-element-type element-type))))) + (sys:array-bits-per-element + (symbol-value (sys:type-array-element-type element-type))))) `(scl:stack-let ((,variable - (make-array - (index-ceiling - (index* (array-total-size ,pixarray) - (sys:array-element-size ,pixarray)) - ,bits-per-element) - :element-type ',element-type - :displaced-to ,pixarray))) + (make-array + (index-ceiling + (index* (array-total-size ,pixarray) + (sys:array-element-size ,pixarray)) + ,bits-per-element) + :element-type ',element-type + :displaced-to ,pixarray))) (declare (type (vector ,element-type) ,variable)) ,@body))) #+lcl3.0 (defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) + ((variable element-type pixarray) &body body) `(let ((,variable (sys:underlying-simple-vector ,pixarray))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) #+excl (defmacro with-underlying-simple-vector - ((variable element-type pixarray) &body body) + ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) @@ -3185,9 +3185,9 @@ Returns a list of (host display-number screen protocol)." (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) - (#-Genera ldb #+Genera sys:%logldb - (byte ,size ,position) - (the card8 ,integer)))) + (#-Genera ldb #+Genera sys:%logldb + (byte ,size ,position) + (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. @@ -3195,13 +3195,13 @@ Returns a list of (host display-number screen protocol)." (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) - (count 0)) + (count 0)) (dolist (byte (rest bytes)) (setq it - `(#-Genera dpb #+Genera sys:%logdpb - (the card8 ,byte) - (byte 8 ,(incf count 8)) - (the (unsigned-byte ,count) ,it)))) + `(#-Genera dpb #+Genera sys:%logdpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) @@ -3212,11 +3212,11 @@ Returns a list of (host display-number screen protocol)." integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 - (#-Genera ldb #+Genera sys:%logldb - (byte 8 ,position) - #-Genera (the (unsigned-byte ,integer-size) ,integer) - #+Genera ,integer - ))) + (#-Genera ldb #+Genera sys:%logldb + (byte 8 ,position) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,integer + ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. @@ -3224,13 +3224,13 @@ Returns a list of (host display-number screen protocol)." (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) - (it (first bytes)) - (count 0)) + (it (first bytes)) + (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb - (the (unsigned-byte ,size) ,byte) - (byte ,size ,(incf count size)) - (the (unsigned-byte ,count) ,it)))) + (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) @@ -3246,29 +3246,29 @@ Returns a list of (host display-number screen protocol)." ;;; for the least significant bit. ;;; ;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant ;;; ;;; -;;; format ordering +;;; format ordering ;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant @@ -3291,31 +3291,31 @@ Returns a list of (host display-number screen protocol)." (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) - (a (make-array '(1 32) :element-type 'bit :initial-element 0))) + (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) - (declare (optimize (speed 3) (safety 0) (space 0))) - (declare (type (simple-array bit (* *)) a) - (type fixnum i n)) - (with-underlying-simple-vector (v (unsigned-byte 8) a) - (prog2 - (setf (aref v i) n) - (dotimes (i 32) - (unless (zerop (aref a 0 i)) - (return i))) - (setf (aref v i) 0))))) - (list (bitpos a i #b10000000) - (bitpos a i #b00000001))) - ordering)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (declare (type (simple-array bit (* *)) a) + (type fixnum i n)) + (with-underlying-simple-vector (v (unsigned-byte 8) a) + (prog2 + (setf (aref v i) n) + (dotimes (i 32) + (unless (zerop (aref a 0 i)) + (return i))) + (setf (aref v i) 0))))) + (list (bitpos a i #b10000000) + (bitpos a i #b00000001))) + ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering - (second (assoc ordering *image-bit-ordering-table* - :test #'equal)))) + (second (assoc ordering *image-bit-ordering-table* + :test #'equal)))) (unless byte-and-bit-ordering - (error "Couldn't determine image byte and bit ordering~@ + (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" - ordering)) + ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) @@ -3338,230 +3338,230 @@ Returns a list of (host display-number screen protocol)." #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index (mod (the fixnum (- x)) 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (the fixnum (- (the fixnum (- width left-bits)) - right-bits))) - (middle-bytes (index-floor middle-bits 8))) - ((index>= y height)) - (declare (type array-index start y - left-bits right-bits middle-bytes) - (fixnum middle-bits)) - (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x (array-row-major-index array y left-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref vector (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref vector (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref vector (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref vector (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref vector (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref vector (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-bits) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (array-row-major-index - array y (index+ left-bits middle-bits)))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref vector (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref vector (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref vector (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref vector (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref vector (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref vector (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (the array-index (mod (the fixnum (- x)) 8))) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (the fixnum (- (the fixnum (- width left-bits)) + right-bits))) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bytes) + (fixnum middle-bits)) + (cond ((< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) - 2))) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) - (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) - (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x (array-row-major-index array y left-nibbles) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref vector (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref vector (index+ x 1)) - (read-image-load-byte 4 4 byte)))) - ))) + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) + 2))) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) - (declare (type array-index start y)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y 0) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref vector x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) t) #+lispm (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) + (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height a x y pixarray 0 0)) t) @@ -3569,10 +3569,10 @@ Returns a list of (host display-number screen protocol)." (defun pixarray-element-size (pixarray) (let ((eltype (array-element-type pixarray))) (cond ((eq eltype 'bit) 1) - ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) - (second eltype)) - (t - (error "Invalid pixarray: ~S." pixarray))))) + ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) + (second eltype)) + (t + (error "Invalid pixarray: ~S." pixarray))))) #+CMU ;;; COPY-BIT-RECT -- Internal @@ -3583,33 +3583,33 @@ Returns a list of (host display-number screen protocol)." ;;; displacement. We allow extra random bit-offset to be thrown into the X. ;;; (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) + height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (kernel::with-array-data ((sdata source) - (sstart) - (send)) + (sstart) + (send)) (declare (ignore send)) (kernel::with-array-data ((ddata dest) - (dstart) - (dend)) + (dstart) + (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) + sx (index* sy source-width)) + (index+ src-idx source-width)) + (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) + dx (index* dy dest-width)) + (index+ dest-idx dest-width)) + (count height (1- count))) + ((zerop count)) + (declare (type array-index src-idx dest-idx count)) + (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) #+sbcl (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy - height width) + height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (sb-kernel:with-array-data ((sdata source) (sstart) (send)) @@ -3618,480 +3618,480 @@ Returns a list of (host display-number screen protocol)." (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - sx (index* sy source-width)) - (index+ src-idx source-width)) - (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - dx (index* dy dest-width)) - (index+ dest-idx dest-width)) - (count height (1- count))) - ((zerop count)) - (declare (type array-index src-idx dest-idx count)) - (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) + sx (index* sy source-width)) + (index+ src-idx source-width)) + (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) + dx (index* dy dest-width)) + (index+ dest-idx dest-width)) + (count height (1- count))) + ((zerop count)) + (declare (type array-index src-idx dest-idx count)) + (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) #+(or CMU sbcl) (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + bits-per-pixel) (declare (type (array * 2) pixarray)) #.(declare-buffun) (copy-bit-rect bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - height - (index* width bits-per-pixel)) + (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 + pixarray + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + height + (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (x-bits (index* x bits-per-pixel))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod x-bits 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod x-bits +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p*) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (dst card8 pixarray) - (funcall - (symbol-function image-swap-function) bbuf dst - (index+ boffset - (index* y padded-bytes-per-line) - (index-floor x-bits 8)) - 0 (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line - (index-floor pixarray-padded-bits-per-line 8) - height image-swap-lsb-first-p))) - t)))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod x-bits 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod x-bits +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p*) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (dst card8 pixarray) + (funcall + (symbol-function image-swap-function) bbuf dst + (index+ boffset + (index* y padded-bytes-per-line) + (index-floor x-bits 8)) + 0 (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line + (index-floor pixarray-padded-bits-per-line 8) + height image-swap-lsb-first-p))) + t)))) (defun fast-read-pixarray (bbuf boffset pixarray - x y width height padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + x y width height padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset - padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-read-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-read-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-read-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-read-pixarray-24)))) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-read-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-read-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-read-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-read-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-read-pixarray-24)))) (when function - (read-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - unit byte-lsb-first-p bit-lsb-first-p - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) + (read-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + unit byte-lsb-first-p bit-lsb-first-p + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-bits middle-bits - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (array-row-major-index - array y (index+ start-x middle-bits)))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (if (index> right-bits 1) - (aref vector (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref vector (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref vector (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref vector (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref vector (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref vector (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)) - (aref vector (index+ x 2)) - (aref vector (index+ x 3)) - (aref vector (index+ x 4)) - (aref vector (index+ x 5)) - (aref vector (index+ x 6)) - (aref vector (index+ x 7)))))))) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x (array-row-major-index array y start-x) (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref vector (index+ x 0)) - (aref vector (index+ x 1)))))))) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) - (declare (type array-index y start)) - (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x (array-row-major-index array y x) (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref vector x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) t) #+lispm (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) - (floor (* padded-bytes-per-line 8) bits-per-pixel))) + (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array - dimensions - :element-type (array-element-type pixarray) - :displaced-to bbuf - :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height pixarray x y a 0 0)) t) #+(or CMU sbcl) (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + bits-per-pixel) #.(declare-buffun) (copy-bit-rect pixarray - (index* (array-dimension pixarray 1) bits-per-pixel) - x y - bbuf - (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) - (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 - height - (index* width bits-per-pixel)) + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + bbuf + (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) + (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 + height + (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line - pixarray-start-bit-offset)) + pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - +image-unit+ *computed-image-byte-lsb-first-p* - *computed-image-bit-lsb-first-p* - unit byte-lsb-first-p bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (with-underlying-simple-vector (src card8 pixarray) - (funcall - (symbol-function image-swap-function) - src bbuf (index-floor pixarray-start-bit-offset 8) boffset - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - padded-bytes-per-line height image-swap-lsb-first-p)) - t))))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + +image-unit+ *computed-image-byte-lsb-first-p* + *computed-image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (with-underlying-simple-vector (src card8 pixarray) + (funcall + (symbol-function image-swap-function) + src bbuf (index-floor pixarray-start-bit-offset 8) boffset + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + padded-bytes-per-line height image-swap-lsb-first-p)) + t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function - (or #+lispm - (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod padded-bytes-per-line 4)) - (zerop (index-mod - (* #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1) - bits-per-pixel) - 32)) - #'fast-write-pixarray-using-bitblt) - #+(or CMU) - (and (index= (pixarray-element-size pixarray) bits-per-pixel) - #'fast-write-pixarray-using-bitblt) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 1) - #'fast-write-pixarray-1) - #+(or lcl3.0 excl) - (and (index= bits-per-pixel 4) - #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl CMU) - (and (index= bits-per-pixel 24) - #'fast-write-pixarray-24)))) + (or #+lispm + (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bytes-per-line 4)) + (zerop (index-mod + (* #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1) + bits-per-pixel) + 32)) + #'fast-write-pixarray-using-bitblt) + #+(or CMU) + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 1) + #'fast-write-pixarray-1) + #+(or lcl3.0 excl) + (and (index= bits-per-pixel 4) + #'fast-write-pixarray-4) + #+(or Genera lcl3.0 excl CMU) + (and (index= bits-per-pixel 24) + #'fast-write-pixarray-24)))) (when function - (write-pixarray-internal - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel function - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ - unit byte-lsb-first-p bit-lsb-first-p))))) + (write-pixarray-internal + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel function + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ + unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line - #+Genera (sys:array-row-span pixarray) - #-Genera (array-dimension pixarray 1)) - (pixarray-padded-bits-per-line - (* pixarray-padded-pixels-per-line bits-per-pixel)) - (copy-padded-pixels-per-line - #+Genera (sys:array-row-span copy) - #-Genera (array-dimension copy 1)) - (copy-padded-bits-per-line - (* copy-padded-pixels-per-line bits-per-pixel))) + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (array-dimension copy 1)) + (copy-padded-bits-per-line + (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) - (zerop (index-mod pixarray-padded-bits-per-line 32)) - (zerop (index-mod copy-padded-bits-per-line 32))) - (sys:bitblt boole-1 width height pixarray x y copy 0 0) - t) + (zerop (index-mod pixarray-padded-bits-per-line 32)) + (zerop (index-mod copy-padded-bits-per-line 32))) + (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t) #+(or CMU) (when (index= (pixarray-element-size pixarray) - (pixarray-element-size copy) - bits-per-pixel) - (copy-bit-rect pixarray pixarray-padded-bits-per-line x y - copy copy-padded-bits-per-line 0 0 - height - (index* width bits-per-pixel)) - t)) - + (pixarray-element-size copy) + bits-per-pixel) + (copy-bit-rect pixarray pixarray-padded-bits-per-line x y + copy copy-padded-bits-per-line 0 0 + height + (index* width bits-per-pixel)) + t)) + #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index pixarray 1 0) - (array-row-major-index pixarray 0 0)) - bits-per-pixel))) - (copy-padded-bits-per-line - (if (index= height 1) 0 - (index* (index- (array-row-major-index copy 1 0) - (array-row-major-index copy 0 0)) - bits-per-pixel))) - (pixarray-start-bit-offset - (index* (array-row-major-index pixarray y x) - bits-per-pixel))) - (declare (type array-index pixarray-padded-bits-per-line - copy-padded-bits-per-line pixarray-start-bit-offset)) - (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) - (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) - (index-zerop (index-mod copy-padded-bits-per-line 8)) - (index-zerop (index-mod pixarray-start-bit-offset 8))) - (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) - (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) - (with-underlying-simple-vector (src card8 pixarray) - (with-underlying-simple-vector (dst card8 copy) - (image-noswap - src dst - (index-floor pixarray-start-bit-offset 8) 0 - (index-ceiling (index* width bits-per-pixel) 8) - (index-floor pixarray-padded-bits-per-line 8) - (index-floor copy-padded-bits-per-line 8) - height nil))) - t))) + (if (index= height 1) 0 + (index* (index- (array-row-major-index pixarray 1 0) + (array-row-major-index pixarray 0 0)) + bits-per-pixel))) + (copy-padded-bits-per-line + (if (index= height 1) 0 + (index* (index- (array-row-major-index copy 1 0) + (array-row-major-index copy 0 0)) + bits-per-pixel))) + (pixarray-start-bit-offset + (index* (array-row-major-index pixarray y x) + bits-per-pixel))) + (declare (type array-index pixarray-padded-bits-per-line + copy-padded-bits-per-line pixarray-start-bit-offset)) + (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) + (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) + (index-zerop (index-mod copy-padded-bits-per-line 8)) + (index-zerop (index-mod pixarray-start-bit-offset 8))) + (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) + (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) + (with-underlying-simple-vector (src card8 pixarray) + (with-underlying-simple-vector (dst card8 copy) + (image-noswap + src dst + (index-floor pixarray-start-bit-offset 8) 0 + (index-ceiling (index* width bits-per-pixel) 8) + (index-floor pixarray-padded-bits-per-line 8) + (index-floor copy-padded-bits-per-line 8) + height nil))) + t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) - `(let ((pixarray pixarray) - (copy copy)) - (declare (type ,type pixarray copy)) - #.(declare-buffun) - (with-underlying-simple-vector (src ,element-type pixarray) - (with-underlying-simple-vector (dst ,element-type copy) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-idx (array-row-major-index copy dst-y 0) - (index1+ dst-idx)) - (dst-end (index+ dst-idx width)) - (src-idx (array-row-major-index pixarray src-y x) - (index1+ src-idx))) - ((index>= dst-idx dst-end)) - (declare (type array-index dst-idx src-idx dst-end)) - (setf (aref dst dst-idx) - (the ,element-type (aref src src-idx)))))))))) + `(let ((pixarray pixarray) + (copy copy)) + (declare (type ,type pixarray copy)) + #.(declare-buffun) + (with-underlying-simple-vector (src ,element-type pixarray) + (with-underlying-simple-vector (dst ,element-type copy) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))) + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) t))) diff --git a/src/clx/display.lisp b/src/clx/display.lisp index ae556939d..9d02f718e 100644 --- a/src/clx/display.lisp +++ b/src/clx/display.lisp @@ -3,9 +3,9 @@ ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -96,42 +96,42 @@ (let ((pathname (authority-pathname))) (when pathname (with-open-file (stream pathname :element-type '(unsigned-byte 8) - :if-does-not-exist nil) - (when stream - (let* ((host-address (and (eql protocol :internet) - (rest (host-address host protocol)))) - (best-name nil) (best-pos nil) - (best-data nil)) - ;; Check for the localhost address, in which case we're - ;; really FamilyLocal. - (when (or (eql protocol :local) - (and (eql protocol :internet) - (equal host-address '(127 0 0 1)))) - (setq host-address (get-host-name)) - (setq protocol :local)) - (loop - (destructuring-bind (family address number name data) - (read-xauth-entry stream) - (unless family (return)) - (when (and (eql family protocol) - (equal host-address address) - (= number display) - (let ((pos1 (position name *known-authorizations* - :test #'string=))) - (and pos1 - (or (null best-pos) - (< pos1 best-pos))))) - (setf best-name name - best-pos (position name *known-authorizations* - :test #'string=) - best-data data)))) - (when best-name - (return-from get-best-authorization - (values best-name best-data))))))) + :if-does-not-exist nil) + (when stream + (let* ((host-address (and (eql protocol :internet) + (rest (host-address host protocol)))) + (best-name nil) (best-pos nil) + (best-data nil)) + ;; Check for the localhost address, in which case we're + ;; really FamilyLocal. + (when (or (eql protocol :local) + (and (eql protocol :internet) + (equal host-address '(127 0 0 1)))) + (setq host-address (get-host-name)) + (setq protocol :local)) + (loop + (destructuring-bind (family address number name data) + (read-xauth-entry stream) + (unless family (return)) + (when (and (eql family protocol) + (equal host-address address) + (= number display) + (let ((pos1 (position name *known-authorizations* + :test #'string=))) + (and pos1 + (or (null best-pos) + (< pos1 best-pos))))) + (setf best-name name + best-pos (position name *known-authorizations* + :test #'string=) + best-data data)))) + (when best-name + (return-from get-best-authorization + (values best-name best-data))))))) (values "" ""))) (defmacro with-display ((display &key timeout inline) - &body body) + &body body) ;; This macro is for use in a multi-process environment. It ;; provides exclusive access to the local display object for ;; multiple request generation. It need not provide immediate @@ -144,8 +144,8 @@ ;; Nested uses of this macro will work correctly. This macro does ;; not prevent concurrent event processing; see with-event-queue. `(with-buffer (,display - ,@(and timeout `(:timeout ,timeout)) - ,@(and inline `(:inline ,inline))) + ,@(and timeout `(:timeout ,timeout)) + ,@(and inline `(:inline ,inline))) ,@body)) ;; @@ -156,12 +156,12 @@ (let ((id-mask (display-resource-id-mask display))) (unless (zerop id-mask) ;; zero mask is an error (do ((first 0 (index1+ first)) - (mask id-mask (the mask32 (ash mask -1)))) - ((oddp mask) - (setf (display-resource-id-byte display) - (byte (integer-length mask) first))) - (declare (type array-index first) - (type mask32 mask)))))) + (mask id-mask (the mask32 (ash mask -1)))) + ((oddp mask) + (setf (display-resource-id-byte display) + (byte (integer-length mask) first))) + (declare (type array-index first) + (type mask32 mask)))))) (defun resourcealloc (display) ;; Allocate a resource-id for use in DISPLAY @@ -207,8 +207,8 @@ (defun save-id (display id object) ;; cache the object associated with ID for this display. (declare (type display display) - (type integer id) - (type t object)) + (type integer id) + (type t object)) (declare (clx-values object)) ;; we can't cache objects from other clients, because they may ;; become invalid without us being told about that. @@ -221,36 +221,36 @@ ;; Define functions to find the CLX data types given a display and resource-id ;; If the data type is being cached, look there first. (macrolet ((generate-lookup-functions (useless-name &body types) - `(within-definition (,useless-name generate-lookup-functions) - ,@(mapcar - #'(lambda (type) - `(defun ,(xintern 'lookup- type) - (display id) - (declare (type display display) - (type resource-id id)) - (declare (clx-values ,type)) - ,(if (member type +clx-cached-types+) - `(let ((,type (lookup-resource-id display id))) - (cond ((null ,type) ;; Not found, create and save it. - (setq ,type (,(xintern 'make- type) - :display display :id id)) - (save-id display id ,type)) - ;; Found. Check the type - ,(cond ((null +type-check?+) - `(t ,type)) - ((member type '(window pixmap)) - `((type? ,type 'drawable) ,type)) - (t `((type? ,type ',type) ,type))) - ,@(when +type-check?+ - `((t (x-error 'lookup-error - :id id - :display display - :type ',type - :object ,type)))))) - ;; Not being cached. Create a new one each time. - `(,(xintern 'make- type) - :display display :id id)))) - types)))) + `(within-definition (,useless-name generate-lookup-functions) + ,@(mapcar + #'(lambda (type) + `(defun ,(xintern 'lookup- type) + (display id) + (declare (type display display) + (type resource-id id)) + (declare (clx-values ,type)) + ,(if (member type +clx-cached-types+) + `(let ((,type (lookup-resource-id display id))) + (cond ((null ,type) ;; Not found, create and save it. + (setq ,type (,(xintern 'make- type) + :display display :id id)) + (save-id display id ,type)) + ;; Found. Check the type + ,(cond ((null +type-check?+) + `(t ,type)) + ((member type '(window pixmap)) + `((type? ,type 'drawable) ,type)) + (t `((type? ,type ',type) ,type))) + ,@(when +type-check?+ + `((t (x-error 'lookup-error + :id id + :display display + :type ',type + :object ,type)))))) + ;; Not being cached. Create a new one each time. + `(,(xintern 'make- type) + :display display :id id)))) + types)))) (generate-lookup-functions ignore drawable window @@ -263,23 +263,23 @@ (defun id-atom (id display) ;; Return the cached atom for an atom ID (declare (type resource-id id) - (type display display)) + (type display display)) (declare (clx-values (or null keyword))) (gethash id (display-atom-id-map display))) (defun atom-id (atom display) ;; Return the ID for an atom in DISPLAY (declare (type xatom atom) - (type display display)) + (type display display)) (declare (clx-values (or null resource-id))) (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom)) - (display-atom-cache display))) + (display-atom-cache display))) (defun set-atom-id (atom display id) ;; Set the ID for an atom in DISPLAY (declare (type xatom atom) - (type display display) - (type resource-id id)) + (type display display) + (type resource-id id)) (declare (clx-values resource-id)) (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom)))) (setf (gethash id (display-atom-id-map display)) atom) @@ -295,8 +295,8 @@ (defun visual-info (display visual-id) (declare (type display display) - (type resource-id visual-id) - (clx-values visual-info)) + (type resource-id visual-id) + (clx-values visual-info)) (when (zerop visual-id) (return-from visual-info nil)) (dolist (screen (display-roots display)) @@ -304,9 +304,9 @@ (dolist (depth (screen-depths screen)) (declare (type cons depth)) (dolist (visual-info (rest depth)) - (declare (type visual-info visual-info)) - (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) - (return-from visual-info visual-info))))) + (declare (type visual-info visual-info)) + (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) + (return-from visual-info visual-info))))) (error "Visual info not found for id #x~x in display ~s." visual-id display)) @@ -314,37 +314,37 @@ ;; Display functions ;; (defmacro with-event-queue ((display &key timeout inline) - &body body &environment env) + &body body &environment env) ;; exclusive access to event queue `(macrolet ((with-event-queue ((display &key timeout) &body body) - ;; Speedup hack for lexically nested with-event-queues - `(progn - (progn ,display ,@(and timeout `(,timeout)) nil) - ,@body))) + ;; Speedup hack for lexically nested with-event-queues + `(progn + (progn ,display ,@(and timeout `(,timeout)) nil) + ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.with-event-queue-body. () ,@body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.with-event-queue-body.)) - (with-event-queue-function - ,display ,timeout #'.with-event-queue-body.)) - (let ((disp (if (or (symbolp display) (constantp display)) - display - '.display.))) - `(let (,@(unless (eq disp display) `((,disp ,display)))) - (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))))) + `(flet ((.with-event-queue-body. () ,@body)) + #+clx-ansi-common-lisp + (declare (dynamic-extent #'.with-event-queue-body.)) + (with-event-queue-function + ,display ,timeout #'.with-event-queue-body.)) + (let ((disp (if (or (symbolp display) (constantp display)) + display + '.display.))) + `(let (,@(unless (eq disp display) `((,disp ,display)))) + (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" + ,@(and timeout `(:timeout ,timeout))) + ,@body)))))) (defun with-event-queue-function (display timeout function) (declare (type display display) - (type (or null number) timeout) - (type function function) - #+clx-ansi-common-lisp - (dynamic-extent function) - ;; FIXME: see SBCL bug #243 - (ignorable display timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (type (or null number) timeout) + (type function function) + #+clx-ansi-common-lisp + (dynamic-extent function) + ;; FIXME: see SBCL bug #243 + (ignorable display timeout) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg function)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) @@ -353,8 +353,8 @@ (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(let (,@(unless (eq disp display) `((,disp ,display)))) (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" - ,@(and timeout `(:timeout ,timeout))) - ,@body)))) + ,@(and timeout `(:timeout ,timeout))) + ,@body)))) (defun open-default-display (&optional display-name) "Open a connection to DISPLAY-NAME if supplied, or to the appropriate @@ -391,30 +391,30 @@ gethostname(3) - is used instead." (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) (get-best-authorization host - display - (if (member host '("" "unix") :test #'equal) - :local - protocol)))) + display + (if (member host '("" "unix") :test #'equal) + :local + protocol)))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal - :host host :display display - :output-stream stream :input-stream stream)) - (ok-p nil)) + (disp (make-buffer *output-buffer-size* #'make-display-internal + :host host :display display + :output-stream stream :input-stream stream)) + (ok-p nil)) (unwind-protect - (progn - (display-connect disp - :authorization-name authorization-name - :authorization-data authorization-data) - (setf (display-authorization-name disp) authorization-name) - (setf (display-authorization-data disp) authorization-data) - (initialize-resource-allocator disp) - (initialize-predefined-atoms disp) - (initialize-extensions disp) - (when (assoc "BIG-REQUESTS" (display-extension-alist disp) - :test #'string=) - (enable-big-requests disp)) - (setq ok-p t)) + (progn + (display-connect disp + :authorization-name authorization-name + :authorization-data authorization-data) + (setf (display-authorization-name disp) authorization-name) + (setf (display-authorization-data disp) authorization-data) + (initialize-resource-allocator disp) + (initialize-predefined-atoms disp) + (initialize-extensions disp) + (when (assoc "BIG-REQUESTS" (display-extension-alist disp) + :test #'string=) + (enable-big-requests disp)) + (setq ok-p t)) (unless ok-p (close-display disp :abort t))) disp)) @@ -434,160 +434,160 @@ gethostname(3) - is used instead." (card8-put 0 (ecase (display-byte-order display) - (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First - (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First + (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First + (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First (card16-put 2 *protocol-major-version*) (card16-put 4 *protocol-minor-version*) (card16-put 6 (length authorization-name)) (card16-put 8 (length authorization-data)) (write-sequence-char display 12 authorization-name) (if (stringp authorization-data) - (write-sequence-char display (lround (+ 12 (length authorization-name))) - authorization-data) - (write-sequence-card8 display (lround (+ 12 (length authorization-name))) - authorization-data))) + (write-sequence-char display (lround (+ 12 (length authorization-name))) + authorization-data) + (write-sequence-card8 display (lround (+ 12 (length authorization-name))) + authorization-data))) (buffer-force-output display) (let ((reply-buffer nil)) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect - (progn - (setq reply-buffer (allocate-reply-buffer #x1000)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (buffer-input display buffer-bbuf 0 8) - (let ((success (boolean-get 0)) - (reason-length (card8-get 1)) - (major-version (card16-get 2)) - (minor-version (card16-get 4)) - (total-length (card16-get 6)) - vendor-length - num-roots - num-formats) - (declare (ignore total-length)) - (unless success - (x-error 'connection-failure - :major-version major-version - :minor-version minor-version - :host (display-host display) - :display (display-display display) - :reason - (progn (buffer-input display buffer-bbuf 0 reason-length) - (string-get reason-length 0 :reply-buffer reply-buffer)))) - (buffer-input display buffer-bbuf 0 32) - (setf (display-protocol-major-version display) major-version) - (setf (display-protocol-minor-version display) minor-version) - (setf (display-release-number display) (card32-get 0)) - (setf (display-resource-id-base display) (card32-get 4)) - (setf (display-resource-id-mask display) (card32-get 8)) - (setf (display-motion-buffer-size display) (card32-get 12)) - (setq vendor-length (card16-get 16)) - (setf (display-max-request-length display) (card16-get 18)) - (setq num-roots (card8-get 20)) - (setq num-formats (card8-get 21)) - ;; Get the image-info - (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) - (let ((format (display-bitmap-format display))) - (declare (type bitmap-format format)) - (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) - (setf (bitmap-format-unit format) (card8-get 24)) - (setf (bitmap-format-pad format) (card8-get 25))) - (setf (display-min-keycode display) (card8-get 26)) - (setf (display-max-keycode display) (card8-get 27)) - ;; 4 bytes unused - ;; Get the vendor string - (buffer-input display buffer-bbuf 0 (lround vendor-length)) - (setf (display-vendor-name display) - (string-get vendor-length 0 :reply-buffer reply-buffer)) - ;; Initialize the pixmap formats - (dotimes (i num-formats) ;; loop gathering pixmap formats - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 8) - (push (make-pixmap-format :depth (card8-get 0) - :bits-per-pixel (card8-get 1) - :scanline-pad (card8-get 2)) - ; 5 unused bytes - (display-pixmap-formats display))) - (setf (display-pixmap-formats display) - (nreverse (display-pixmap-formats display))) - ;; Initialize the screens - (dotimes (i num-roots) - (declare (ignorable i)) - (buffer-input display buffer-bbuf 0 40) - (let* ((root-id (card32-get 0)) - (root (make-window :id root-id :display display)) - (root-visual (card32-get 32)) - (default-colormap-id (card32-get 4)) - (default-colormap - (make-colormap :id default-colormap-id :display display)) - (screen - (make-screen - :root root - :default-colormap default-colormap - :white-pixel (card32-get 8) - :black-pixel (card32-get 12) - :event-mask-at-open (card32-get 16) - :width (card16-get 20) - :height (card16-get 22) - :width-in-millimeters (card16-get 24) - :height-in-millimeters (card16-get 26) - :min-installed-maps (card16-get 28) - :max-installed-maps (card16-get 30) - :backing-stores (member8-get 36 :never :when-mapped :always) - :save-unders-p (boolean-get 37) - :root-depth (card8-get 38))) - (num-depths (card8-get 39)) - (depths nil)) - ;; Save root window for event reporting - (save-id display root-id root) - (save-id display default-colormap-id default-colormap) - ;; Create the depth AList for a screen, (depth . visual-infos) - (dotimes (j num-depths) - (declare (ignorable j)) - (buffer-input display buffer-bbuf 0 8) - (let ((depth (card8-get 0)) - (num-visuals (card16-get 2)) - (visuals nil)) ;; 4 bytes unused - (dotimes (k num-visuals) - (declare (ignorable k)) - (buffer-input display buffer-bbuf 0 24) - (let* ((visual (card32-get 0)) - (visual-info (make-visual-info - :id visual - :display display - :class (member8-get 4 :static-gray :gray-scale - :static-color :pseudo-color - :true-color :direct-color) - :bits-per-rgb (card8-get 5) - :colormap-entries (card16-get 6) - :red-mask (card32-get 8) - :green-mask (card32-get 12) - :blue-mask (card32-get 16) - ;; 4 bytes unused - ))) - (push visual-info visuals) - (when (funcall (resource-id-map-test) root-visual visual) - (setf (screen-root-visual-info screen) - (setf (colormap-visual-info default-colormap) - visual-info))))) - (push (cons depth (nreverse visuals)) depths))) - (setf (screen-depths screen) (nreverse depths)) - (push screen (display-roots display)))) - (setf (display-roots display) (nreverse (display-roots display))) - (setf (display-default-screen display) (first (display-roots display)))))) + (progn + (setq reply-buffer (allocate-reply-buffer #x1000)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (buffer-input display buffer-bbuf 0 8) + (let ((success (boolean-get 0)) + (reason-length (card8-get 1)) + (major-version (card16-get 2)) + (minor-version (card16-get 4)) + (total-length (card16-get 6)) + vendor-length + num-roots + num-formats) + (declare (ignore total-length)) + (unless success + (x-error 'connection-failure + :major-version major-version + :minor-version minor-version + :host (display-host display) + :display (display-display display) + :reason + (progn (buffer-input display buffer-bbuf 0 reason-length) + (string-get reason-length 0 :reply-buffer reply-buffer)))) + (buffer-input display buffer-bbuf 0 32) + (setf (display-protocol-major-version display) major-version) + (setf (display-protocol-minor-version display) minor-version) + (setf (display-release-number display) (card32-get 0)) + (setf (display-resource-id-base display) (card32-get 4)) + (setf (display-resource-id-mask display) (card32-get 8)) + (setf (display-motion-buffer-size display) (card32-get 12)) + (setq vendor-length (card16-get 16)) + (setf (display-max-request-length display) (card16-get 18)) + (setq num-roots (card8-get 20)) + (setq num-formats (card8-get 21)) + ;; Get the image-info + (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) + (let ((format (display-bitmap-format display))) + (declare (type bitmap-format format)) + (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) + (setf (bitmap-format-unit format) (card8-get 24)) + (setf (bitmap-format-pad format) (card8-get 25))) + (setf (display-min-keycode display) (card8-get 26)) + (setf (display-max-keycode display) (card8-get 27)) + ;; 4 bytes unused + ;; Get the vendor string + (buffer-input display buffer-bbuf 0 (lround vendor-length)) + (setf (display-vendor-name display) + (string-get vendor-length 0 :reply-buffer reply-buffer)) + ;; Initialize the pixmap formats + (dotimes (i num-formats) ;; loop gathering pixmap formats + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 8) + (push (make-pixmap-format :depth (card8-get 0) + :bits-per-pixel (card8-get 1) + :scanline-pad (card8-get 2)) + ; 5 unused bytes + (display-pixmap-formats display))) + (setf (display-pixmap-formats display) + (nreverse (display-pixmap-formats display))) + ;; Initialize the screens + (dotimes (i num-roots) + (declare (ignorable i)) + (buffer-input display buffer-bbuf 0 40) + (let* ((root-id (card32-get 0)) + (root (make-window :id root-id :display display)) + (root-visual (card32-get 32)) + (default-colormap-id (card32-get 4)) + (default-colormap + (make-colormap :id default-colormap-id :display display)) + (screen + (make-screen + :root root + :default-colormap default-colormap + :white-pixel (card32-get 8) + :black-pixel (card32-get 12) + :event-mask-at-open (card32-get 16) + :width (card16-get 20) + :height (card16-get 22) + :width-in-millimeters (card16-get 24) + :height-in-millimeters (card16-get 26) + :min-installed-maps (card16-get 28) + :max-installed-maps (card16-get 30) + :backing-stores (member8-get 36 :never :when-mapped :always) + :save-unders-p (boolean-get 37) + :root-depth (card8-get 38))) + (num-depths (card8-get 39)) + (depths nil)) + ;; Save root window for event reporting + (save-id display root-id root) + (save-id display default-colormap-id default-colormap) + ;; Create the depth AList for a screen, (depth . visual-infos) + (dotimes (j num-depths) + (declare (ignorable j)) + (buffer-input display buffer-bbuf 0 8) + (let ((depth (card8-get 0)) + (num-visuals (card16-get 2)) + (visuals nil)) ;; 4 bytes unused + (dotimes (k num-visuals) + (declare (ignorable k)) + (buffer-input display buffer-bbuf 0 24) + (let* ((visual (card32-get 0)) + (visual-info (make-visual-info + :id visual + :display display + :class (member8-get 4 :static-gray :gray-scale + :static-color :pseudo-color + :true-color :direct-color) + :bits-per-rgb (card8-get 5) + :colormap-entries (card16-get 6) + :red-mask (card32-get 8) + :green-mask (card32-get 12) + :blue-mask (card32-get 16) + ;; 4 bytes unused + ))) + (push visual-info visuals) + (when (funcall (resource-id-map-test) root-visual visual) + (setf (screen-root-visual-info screen) + (setf (colormap-visual-info default-colormap) + visual-info))))) + (push (cons depth (nreverse visuals)) depths))) + (setf (screen-depths screen) (nreverse depths)) + (push screen (display-roots display)))) + (setf (display-roots display) (nreverse (display-roots display))) + (setf (display-default-screen display) (first (display-roots display)))))) (when reply-buffer - (deallocate-reply-buffer reply-buffer)))) + (deallocate-reply-buffer reply-buffer)))) display) (defun display-protocol-version (display) (declare (type display display)) (declare (clx-values major minor)) (values (display-protocol-major-version display) - (display-protocol-minor-version display))) + (display-protocol-minor-version display))) (defun display-vendor (display) (declare (type display display)) (declare (clx-values name release)) (values (display-vendor-name display) - (display-release-number display))) + (display-release-number display))) (defun display-nscreens (display) (declare (type display display)) @@ -632,7 +632,7 @@ gethostname(3) - is used instead." ; Called after every protocal request is generated (declare (type display display)) (when (and (display-after-function display) - (not *inside-display-after-function*)) + (not *inside-display-after-function*)) (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls (funcall (display-after-function display) display)))) diff --git a/src/clx/exclcmac.lisp b/src/clx/exclcmac.lisp index 04fd20af8..67f63ddd9 100644 --- a/src/clx/exclcmac.lisp +++ b/src/clx/exclcmac.lisp @@ -23,28 +23,28 @@ (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) + (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) (excl:defcmacro card16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) + (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) (excl:defcmacro int8p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) + (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) (excl:defcmacro int16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) - (fixnum ,xx)) + (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) ;; Card29p, card32p, int32p are too large to expand inline @@ -59,8 +59,8 @@ ,(declare-bufmac) (declare (type card8 ,xx)) (the int8 (if (logbitp 7 ,xx) - (the int8 (- ,xx #x100)) - ,xx))))) + (the int8 (- ,xx #x100)) + ,xx))))) (excl:defcmacro int8->card8 (x) `(locally ,(declare-bufmac) (the card8 (ldb (byte 8 0) (the int8 ,x))))) @@ -71,8 +71,8 @@ ,(declare-bufmac) (declare (type card16 ,xx)) (the int16 (if (logbitp 15 ,xx) - (the int16 (- ,xx #x10000)) - ,xx))))) + (the int16 (- ,xx #x10000)) + ,xx))))) (excl:defcmacro int16->card16 (x) `(locally ,(declare-bufmac) @@ -84,8 +84,8 @@ ,(declare-bufmac) (declare (type card32 ,xx)) (the int32 (if (logbitp 31 ,xx) - (the int32 (- ,xx #x100000000)) - ,xx))))) + (the int32 (- ,xx #x100000000)) + ,xx))))) (excl:defcmacro int32->card32 (x) `(locally ,(declare-bufmac) @@ -106,108 +106,108 @@ (excl:defcmacro aref-card8 (a i) `(locally ,(declare-bufmac) (the card8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte)))) (excl:defcmacro aset-card8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-byte) - (the card8 ,v)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-byte) + (the card8 ,v)))) (excl:defcmacro aref-int8 (a i) `(locally ,(declare-bufmac) (the int8 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte)))) (excl:defcmacro aset-int8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-byte) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-byte) (the int8 ,v)))) (excl:defcmacro aref-card16 (a i) `(locally ,(declare-bufmac) (the card16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word)))) (excl:defcmacro aset-card16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-word) - (the card16 ,v)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-word) + (the card16 ,v)))) (excl:defcmacro aref-int16 (a i) `(locally ,(declare-bufmac) (the int16 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word)))) (excl:defcmacro aset-int16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-word) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-word) (the int16 ,v)))) (excl:defcmacro aref-card32 (a i) `(locally ,(declare-bufmac) (the card32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) (excl:defcmacro aset-card32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) (the card32 ,v)))) (excl:defcmacro aref-int32 (a i) `(locally ,(declare-bufmac) (the int32 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long)))) (excl:defcmacro aset-int32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :signed-long) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :signed-long) (the int32 ,v)))) (excl:defcmacro aref-card29 (a i) ;; Don't need to mask bits here since X protocol guarantees top bits zero `(locally ,(declare-bufmac) (the card29 (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long)))) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long)))) (excl:defcmacro aset-card29 (v a i) ;; I also assume here Lisp is passing a number that fits in 29 bits. `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) - #.(comp::mdparam 'comp::md-svector-data0-adj) - (the array-index ,i) - :unsigned-long) + #.(comp::mdparam 'comp::md-svector-data0-adj) + (the array-index ,i) + :unsigned-long) (the card29 ,v)))) ;; @@ -218,20 +218,20 @@ (let ((f (gensym))) `(let ((,f ,font)) (or (font-id-internal ,f) - (open-font-internal ,f))))) + (open-font-internal ,f))))) (excl:defcmacro font-font-info (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-font-info-internal ,f) - (query-font ,f))))) + (query-font ,f))))) (excl:defcmacro font-char-infos (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-char-infos-internal ,f) - (progn (query-font ,f) - (font-char-infos-internal ,f)))))) + (progn (query-font ,f) + (font-char-infos-internal ,f)))))) ;; @@ -239,22 +239,22 @@ ;; (excl:defcmacro current-process () `(the (or mp::process null) (and mp::*scheduler-stack-group* - mp::*current-process*))) + mp::*current-process*))) (excl:defcmacro process-wakeup (process) (let ((proc (gensym))) `(let ((.pw-curproc. mp::*current-process*) - (,proc ,process)) + (,proc ,process)) (when (and .pw-curproc. ,proc) - (if (> (mp::process-priority ,proc) - (mp::process-priority .pw-curproc.)) - (mp::process-allow-schedule ,proc)))))) + (if (> (mp::process-priority ,proc) + (mp::process-priority .pw-curproc.)) + (mp::process-allow-schedule ,proc)))))) (excl:defcmacro buffer-new-request-number (buffer) (let ((buf (gensym))) `(let ((,buf ,buffer)) (declare (type buffer ,buf)) (setf (buffer-request-number ,buf) - (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) + (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) diff --git a/src/clx/excldefsys.lisp b/src/clx/excldefsys.lisp index abbc5dc71..628bdb50a 100644 --- a/src/clx/excldefsys.lisp +++ b/src/clx/excldefsys.lisp @@ -26,8 +26,8 @@ ;; (setq compiler::generate-interrupt-checks-switch (compile nil '(lambda (safety size speed) - (declare (ignore size)) - (or (< speed 3) (> safety 0))))) + (declare (ignore size)) + (or (< speed 3) (> safety 0))))) #+allegro @@ -35,75 +35,75 @@ () |depdefs| (|clx| :load-before-compile (|depdefs|) - :recompile-on (|depdefs|)) + :recompile-on (|depdefs|)) (|dependent| :load-before-compile (|depdefs| |clx|) - :recompile-on (|clx|)) + :recompile-on (|clx|)) (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) - :recompile-on (|dependent|)) + :recompile-on (|dependent|)) (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) - :recompile-on (|exclcmac|)) + :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros|) - :recompile-on (|macros|)) + |macros|) + :recompile-on (|macros|)) (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac|) - :recompile-on (|bufmac|)) + |macros| |bufmac|) + :recompile-on (|bufmac|)) (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer|) - :recompile-on (|buffer|)) + |macros| |bufmac| |buffer|) + :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |input|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display| |input|) + :recompile-on (|display|)) (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |fonts|) - :recompile-on (|fonts|)) + |macros| |bufmac| |buffer| + |display| |fonts|) + :recompile-on (|fonts|)) (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| - |bufmac| |buffer| |display| - |gcontext| |fonts|) - :recompile-on (|gcontext| |fonts|) - :load-after (|translate|)) + |bufmac| |buffer| |display| + |gcontext| |fonts|) + :recompile-on (|gcontext| |fonts|) + :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |text|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display| |text|) + :recompile-on (|display|)) (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display| |translate|) - :recompile-on (|translate|)) + |macros| |bufmac| |buffer| + |display| |translate|) + :recompile-on (|translate|)) (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| |display| - ) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| |display| + ) + :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| - |macros| |bufmac| |buffer| - |display|) - :recompile-on (|display|)) + |macros| |bufmac| |buffer| + |display|) + :recompile-on (|display|)) ) #+allegro @@ -116,7 +116,7 @@ (defun compile-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) + (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (compile-file "depdefs") (load "depdefs") @@ -147,7 +147,7 @@ (compile-file "attributes") (load "attributes") (load "translate") - (compile-file "translate") ; work-around bug in 2.0 and 2.2 + (compile-file "translate") ; work-around bug in 2.0 and 2.2 (load "translate") (compile-file "keysyms") (load "keysyms") @@ -162,7 +162,7 @@ (defun load-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* - (or pathname-defaults *default-pathname-defaults*))) + (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (load "depdefs") (load "clx") diff --git a/src/clx/excldep.lisp b/src/clx/excldep.lisp index 940a70f7c..445a2244d 100644 --- a/src/clx/excldep.lisp +++ b/src/clx/excldep.lisp @@ -17,9 +17,9 @@ (eval-when (compile load eval) (require :foreign) - (require :process) ; Needed even if scheduler is not - ; running. (Must be able to make - ; a process-lock.) + (require :process) ; Needed even if scheduler is not + ; running. (Must be able to make + ; a process-lock.) ) (eval-when (load) @@ -30,9 +30,9 @@ (eval-when (eval compile load) (let ((x '#(1))) (if (not (eq 0 (sys::memref x - #.(sys::mdparam 'comp::md-lvector-data0-norm) - 0 :unsigned-byte))) - (pushnew :little-endian *features*) + #.(sys::mdparam 'comp::md-lvector-data0-norm) + 0 :unsigned-byte))) + (pushnew :little-endian *features*) (pushnew :big-endian *features*)))) @@ -42,12 +42,12 @@ (let ((str (gensym))) `(let ((,str ,string)) (case excl::*current-case-mode* - (:case-insensitive-lower - (string-downcase ,str)) - (:case-insensitive-upper - (string-upcase ,str)) - ((:case-sensitive-lower :case-sensitive-upper) - ,str))))) + (:case-insensitive-lower + (string-downcase ,str)) + (:case-insensitive-upper + (string-upcase ,str)) + ((:case-sensitive-lower :case-sensitive-upper) + ,str))))) (defconstant type-pred-alist @@ -102,7 +102,7 @@ #-(version>= 4 1 devel 16) (defun card8p (x) (declare (optimize (speed 3) (safety 0)) - (fixnum x)) + (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) t nil)) @@ -110,7 +110,7 @@ #-(version>= 4 1 devel 16) (defun card16p (x) (declare (optimize (speed 3) (safety 0)) - (fixnum x)) + (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) t nil)) @@ -119,8 +119,8 @@ (defun card29p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) - (>= (the bignum x) 0))) + (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) + (>= (the bignum x) 0))) t nil)) @@ -128,15 +128,15 @@ (defun card32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) - (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) - (>= (the bignum x) 0))) + (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) + (>= (the bignum x) 0))) t nil)) #-(version>= 4 1 devel 16) (defun int8p (x) (declare (optimize (speed 3) (safety 0)) - (fixnum x)) + (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) t nil)) @@ -144,7 +144,7 @@ #-(version>= 4 1 devel 16) (defun int16p (x) (declare (optimize (speed 3) (safety 0)) - (fixnum x)) + (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) t nil)) @@ -153,8 +153,8 @@ (defun int32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (excl:fixnump x) - (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) - (>= (the bignum x) #.(expt -2 31)))) + (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) + (>= (the bignum x) #.(expt -2 31)))) t nil)) @@ -164,20 +164,20 @@ (defun anglep (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) - (<= (the fixnum x) #.(truncate (* 2 pi)))) - (and (excl::single-float-p x) - (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) - (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) - (and (excl::double-float-p x) - (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) - (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) + (<= (the fixnum x) #.(truncate (* 2 pi)))) + (and (excl::single-float-p x) + (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) + (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) + (and (excl::double-float-p x) + (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) + (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) t nil)) (eval-when (load eval) #+(version>= 4 1 devel 16) (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) - type-pred-alist) + type-pred-alist) #-(version>= 4 1 devel 16) (nconc excl::type-pred-alist type-pred-alist)) @@ -222,17 +222,17 @@ (declare (fixnum next-index start-index length)) (with-interrupt-checking-on (let ((end-index (+ start-index length))) - (loop - (let ((next-index (excl:read-vector vector fd - :start start-index - :end end-index))) - (excl:if* (eq next-index start-index) - then ; end of file before was all filled up - (return t) - elseif (eq next-index end-index) - then ; we're all done - (return nil) - else (setq start-index next-index))))))) + (loop + (let ((next-index (excl:read-vector vector fd + :start start-index + :end end-index))) + (excl:if* (eq next-index start-index) + then ; end of file before was all filled up + (return t) + elseif (eq next-index end-index) + then ; we're all done + (return nil) + else (setq start-index next-index))))))) ;; special patch for CLX (various process fixes) @@ -249,10 +249,10 @@ #+allegro (eval-when (compile eval load) (when (and (= excl::cl-major-version-number 3) - (or (= excl::cl-minor-version-number 0) - (and (= excl::cl-minor-version-number 1) - excl::cl-generation-number - (< excl::cl-generation-number 9)))) + (or (= excl::cl-minor-version-number 0) + (and (= excl::cl-minor-version-number 1) + excl::cl-generation-number + (< excl::cl-generation-number 9)))) (push :clx-r4-process-patches *features*))) #+clx-r4-process-patches @@ -275,46 +275,46 @@ ;; secs is now a nonegative integer, and msecs is either fixnum zero ;; or else something interesting. (unless (eq 0 msecs) - (setq msecs (truncate (* 1000.0 msecs)))) + (setq msecs (truncate (* 1000.0 msecs)))) ;; Now msecs is also a nonnegative fixnum. (multiple-value-bind (now mnow) (excl::cl-internal-real-time) - (incf secs now) - (incf msecs mnow) - (when (>= msecs 1000) - (decf msecs 1000) - (incf secs)) - (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) - (setf (clock-event-secs clock-event) secs - (clock-event-msecs clock-event) msecs - (clock-event-function clock-event) fnc - (clock-event-args clock-event) args))) + (incf secs now) + (incf msecs mnow) + (when (>= msecs 1000) + (decf msecs 1000) + (incf secs)) + (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) + (setf (clock-event-secs clock-event) secs + (clock-event-msecs clock-event) msecs + (clock-event-function clock-event) fnc + (clock-event-args clock-event) args))) clock-event)) #+clx-r4-process-patches (defmacro with-timeout ((seconds &body timeout-body) &body body) `(let* ((clock-event (with-timeout-event ,seconds - #'process-interrupt - (cons *current-process* - '(with-timeout-internal)))) - (excl::*without-interrupts* t) - ret) + #'process-interrupt + (cons *current-process* + '(with-timeout-internal)))) + (excl::*without-interrupts* t) + ret) (unwind-protect - ;; Warning: Branch tensioner better not reorder this code! - (setq ret (catch 'with-timeout-internal - (add-to-clock-queue clock-event) - (let ((excl::*without-interrupts* nil)) - (multiple-value-list (progn ,@body))))) + ;; Warning: Branch tensioner better not reorder this code! + (setq ret (catch 'with-timeout-internal + (add-to-clock-queue clock-event) + (let ((excl::*without-interrupts* nil)) + (multiple-value-list (progn ,@body))))) (excl:if* (eq ret 'with-timeout-internal) - then (let ((excl::*without-interrupts* nil)) - (setq ret (multiple-value-list (progn ,@timeout-body)))) - else (remove-from-clock-queue clock-event))) + then (let ((excl::*without-interrupts* nil)) + (setq ret (multiple-value-list (progn ,@timeout-body)))) + else (remove-from-clock-queue clock-event))) (values-list ret))) #+clx-r4-process-patches (defun process-lock (lock &optional (lock-value *current-process*) - (whostate "Lock") timeout) + (whostate "Lock") timeout) (declare (optimize (speed 3))) (unless (process-lock-p lock) (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) @@ -322,31 +322,31 @@ (excl:if* (null (process-lock-locker lock)) then (setf (process-lock-locker lock) lock-value) else (excl:if* timeout - then (excl:if* (or (eq 0 timeout) ;for speed - (zerop timeout)) - then nil - else (with-timeout (timeout) - (process-lock-1 lock lock-value whostate))) - else (process-lock-1 lock lock-value whostate))))) + then (excl:if* (or (eq 0 timeout) ;for speed + (zerop timeout)) + then nil + else (with-timeout (timeout) + (process-lock-1 lock lock-value whostate))) + else (process-lock-1 lock lock-value whostate))))) #+clx-r4-process-patches (defun process-lock-1 (lock lock-value whostate) (declare (type process-lock lock) - (optimize (speed 3))) + (optimize (speed 3))) (let ((process *current-process*)) (declare (type process process)) (unless process (error "PROCESS-LOCK may not be called on the scheduler's stack group.")) (loop (unless (process-lock-locker lock) - (return (setf (process-lock-locker lock) lock-value))) + (return (setf (process-lock-locker lock) lock-value))) (push process (process-lock-waiting lock)) (let ((saved-whostate (process-whostate process))) - (unwind-protect - (progn (setf (process-whostate process) whostate) - (process-add-arrest-reason process lock)) - (setf (process-whostate process) saved-whostate)))))) + (unwind-protect + (progn (setf (process-whostate process) whostate) + (process-add-arrest-reason process lock)) + (setf (process-whostate process) saved-whostate)))))) #+clx-r4-process-patches @@ -368,17 +368,17 @@ "Process-wait may not be called within the scheduler's stack group.")) (let ((saved-whostate (process-whostate process))) (unwind-protect - (without-scheduling-internal - (without-interrupts - (setf (process-whostate process) whostate - (process-wait-function process) function - (process-wait-args process) args) - (chain-rem-q process) - (chain-ins-q process *waiting-processes*)) - (process-resume-scheduler nil)) - (setf (process-whostate process) saved-whostate - (process-wait-function process) nil - (process-wait-args process) nil))))) + (without-scheduling-internal + (without-interrupts + (setf (process-whostate process) whostate + (process-wait-function process) function + (process-wait-args process) args) + (chain-rem-q process) + (chain-ins-q process *waiting-processes*)) + (process-resume-scheduler nil)) + (setf (process-whostate process) saved-whostate + (process-wait-function process) nil + (process-wait-args process) nil))))) #+clx-r4-process-patches @@ -410,26 +410,26 @@ #+clx-r4-process-patches (defun wait-for-input-available (stream-or-fd &key (wait-function #'listen) - (whostate "waiting for input") - timeout) + (whostate "waiting for input") + timeout) (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd - elseif (streamp stream-or-fd) - then (excl::stream-input-fn stream-or-fd) - else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) + elseif (streamp stream-or-fd) + then (excl::stream-input-fn stream-or-fd) + else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) ;; At this point fd could be nil, since stream-input-fn returns nil for ;; streams that are output only, or for certain special purpose streams. (if fd - (unwind-protect - (progn - (mp::mpwatchfor fd) - (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)) - (mp::mpunwatchfor fd)) + (unwind-protect + (progn + (mp::mpwatchfor fd) + (excl:if* timeout + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)) + (mp::mpunwatchfor fd)) (excl:if* timeout - then (mp::process-wait-with-timeout - whostate timeout wait-function stream-or-fd) - else (mp::process-wait whostate wait-function stream-or-fd) - t)))) + then (mp::process-wait-with-timeout + whostate timeout wait-function stream-or-fd) + else (mp::process-wait whostate wait-function stream-or-fd) + t)))) diff --git a/src/clx/fonts.lisp b/src/clx/fonts.lisp index a5bd4daaf..b8dd832a7 100644 --- a/src/clx/fonts.lisp +++ b/src/clx/fonts.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -30,108 +30,108 @@ ; ;; (or an in-bounds index on a pseudo font), although returning zero or ; ;; signalling might be better. ; (declare (type font font) -; (type integer index) -; (clx-values (or null integer)))) +; (type integer index) +; (clx-values (or null integer)))) ;(defun max-char- (font) ; ;; Note: I have tentatively chosen separate accessors over allowing :min and ; ;; :max as an index above. ; (declare (type font font) -; (clx-values integer))) +; (clx-values integer))) ;(defun min-char- (font) ; (declare (type font font) -; (clx-values integer))) +; (clx-values integer))) ;; Note: char16- accessors could be defined to accept two-byte indexes. (deftype char-info-vec () '(simple-array int16 (*))) (macrolet ((def-char-info-accessors (useless-name &body fields) - `(within-definition (,useless-name def-char-info-accessors) - ,@(do ((field fields (cdr field)) - (n 0 (1+ n)) - (name) (type) - (result nil)) - ((endp field) result) - (setq name (xintern 'char- (caar field))) - (setq type (cadar field)) - (flet ((from (form) - (if (eq type 'int16) - form - `(,(xintern 'int16-> type) ,form)))) - (push - `(defun ,name (font index) - (declare (type font font) - (type array-index index)) - (declare (clx-values (or null ,type))) - (when (and (font-name font) - (index>= (font-max-char font) index (font-min-char font))) - (the ,type - ,(from - `(the int16 - (let ((char-info-vector (font-char-infos font))) - (declare (type char-info-vec char-info-vector)) - (if (index-zerop (length char-info-vector)) - ;; Fixed width font - (aref (the char-info-vec - (font-max-bounds font)) - ,n) - ;; Variable width font - (aref char-info-vector - (index+ - (index* - 6 - (index- - index - (font-min-char font))) - ,n))))))))) - result) - (setq name (xintern 'min-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-min-bounds font)) - ,n)))))) - result) - (setq name (xintern 'max-char- (caar field))) - (push - `(defun ,name (font) - (declare (type font font)) - (declare (clx-values (or null ,type))) - (when (font-name font) - (the ,type - ,(from - `(the int16 - (aref (the char-info-vec (font-max-bounds font)) - ,n)))))) - result))) - - (defun make-char-info - (&key ,@(mapcar - #'(lambda (field) - `(,(car field) (required-arg ,(car field)))) - fields)) - (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) - (let ((result (make-array ,(length fields) :element-type 'int16))) - (declare (type char-info-vec result)) - ,@(do* ((field fields (cdr field)) - (var (caar field) (caar field)) - (type (cadar field) (cadar field)) - (n 0 (1+ n)) - (result nil)) - ((endp field) (nreverse result)) - (push `(setf (aref result ,n) - ,(if (eq type 'int16) - var - `(,(xintern type '->int16) ,var))) - result)) - result))))) + `(within-definition (,useless-name def-char-info-accessors) + ,@(do ((field fields (cdr field)) + (n 0 (1+ n)) + (name) (type) + (result nil)) + ((endp field) result) + (setq name (xintern 'char- (caar field))) + (setq type (cadar field)) + (flet ((from (form) + (if (eq type 'int16) + form + `(,(xintern 'int16-> type) ,form)))) + (push + `(defun ,name (font index) + (declare (type font font) + (type array-index index)) + (declare (clx-values (or null ,type))) + (when (and (font-name font) + (index>= (font-max-char font) index (font-min-char font))) + (the ,type + ,(from + `(the int16 + (let ((char-info-vector (font-char-infos font))) + (declare (type char-info-vec char-info-vector)) + (if (index-zerop (length char-info-vector)) + ;; Fixed width font + (aref (the char-info-vec + (font-max-bounds font)) + ,n) + ;; Variable width font + (aref char-info-vector + (index+ + (index* + 6 + (index- + index + (font-min-char font))) + ,n))))))))) + result) + (setq name (xintern 'min-char- (caar field))) + (push + `(defun ,name (font) + (declare (type font font)) + (declare (clx-values (or null ,type))) + (when (font-name font) + (the ,type + ,(from + `(the int16 + (aref (the char-info-vec (font-min-bounds font)) + ,n)))))) + result) + (setq name (xintern 'max-char- (caar field))) + (push + `(defun ,name (font) + (declare (type font font)) + (declare (clx-values (or null ,type))) + (when (font-name font) + (the ,type + ,(from + `(the int16 + (aref (the char-info-vec (font-max-bounds font)) + ,n)))))) + result))) + + (defun make-char-info + (&key ,@(mapcar + #'(lambda (field) + `(,(car field) (required-arg ,(car field)))) + fields)) + (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) + (let ((result (make-array ,(length fields) :element-type 'int16))) + (declare (type char-info-vec result)) + ,@(do* ((field fields (cdr field)) + (var (caar field) (caar field)) + (type (cadar field) (cadar field)) + (n 0 (1+ n)) + (result nil)) + ((endp field) (nreverse result)) + (push `(setf (aref result ,n) + ,(if (eq type 'int16) + var + `(,(xintern type '->int16) ,var))) + result)) + result))))) (def-char-info-accessors ignore (left-bearing int16) (right-bearing int16) @@ -145,22 +145,22 @@ ;; object. This function might not execute a with-display if the font is cached. ;; The protocol QueryFont request happens on-demand under the covers. (declare (type display display) - (type stringable name)) + (type stringable name)) (declare (clx-values font)) (let* ((name-string (string-downcase (string name))) - (font (car (member name-string (display-font-cache display) - :key 'font-name - :test 'equal))) - font-id) + (font (car (member name-string (display-font-cache display) + :key 'font-name + :test 'equal))) + font-id) (unless font (setq font (make-font :display display :name name-string)) (setq font-id (allocate-resource-id display font 'font)) (setf (font-id-internal font) font-id) (with-buffer-request (display +x-openfont+) - (resource-id font-id) - (card16 (length name-string)) - (pad16 nil) - (string name-string)) + (resource-id font-id) + (card16 (length name-string)) + (pad16 nil) + (string name-string)) (push font (display-font-cache display))) (incf (font-reference-count font)) (unless (font-font-info-internal font) @@ -172,8 +172,8 @@ (declare (type font font)) (declare (clx-values resource-id)) (let* ((name-string (font-name font)) - (display (font-display font)) - (id (allocate-resource-id display font 'font))) + (display (font-display font)) + (id (allocate-resource-id display font 'font))) (setf (font-id-internal font) id) (with-buffer-request (display +x-openfont+) (resource-id id) @@ -189,52 +189,52 @@ ;; simply a performance hint for memory-limited systems. (declare (type font font)) (setf (font-font-info-internal font) nil - (font-char-infos-internal font) nil)) + (font-char-infos-internal font) nil)) (defun query-font (font) ;; Internal function called by font and char info accessors (declare (type font font)) (declare (clx-values font-info)) (let ((display (font-display font)) - font-id - font-info - props) + font-id + font-info + props) (setq font-id (font-id font)) ;; May issue an open-font request (with-buffer-request-and-reply (display +x-queryfont+ 60) - ((resource-id font-id)) + ((resource-id font-id)) (let* ((min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (nchar-infos (index* (card32-get 56) 6)) - (char-info (make-array nchar-infos :element-type 'int16))) - (setq font-info - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24))) - (setq props (sequence-get :length (index* 2 nfont-props) :format int32 - :result-type 'list :index 60)) - (sequence-get :length nchar-infos :format int16 :data char-info - :index (index+ 60 (index* 2 nfont-props 4))) - (setf (font-char-infos-internal font) char-info) - (setf (font-font-info-internal font) font-info))) + (max-byte2 (card16-get 42)) + (min-byte1 (card8-get 49)) + (max-byte1 (card8-get 50)) + (min-char min-byte2) + (max-char (index+ (index-ash max-byte1 8) max-byte2)) + (nfont-props (card16-get 46)) + (nchar-infos (index* (card32-get 56) 6)) + (char-info (make-array nchar-infos :element-type 'int16))) + (setq font-info + (make-font-info + :direction (member8-get 48 :left-to-right :right-to-left) + :min-char min-char + :max-char max-char + :min-byte1 min-byte1 + :max-byte1 max-byte1 + :min-byte2 min-byte2 + :max-byte2 max-byte2 + :all-chars-exist-p (boolean-get 51) + :default-char (card16-get 44) + :ascent (int16-get 52) + :descent (int16-get 54) + :min-bounds (char-info-get 8) + :max-bounds (char-info-get 24))) + (setq props (sequence-get :length (index* 2 nfont-props) :format int32 + :result-type 'list :index 60)) + (sequence-get :length nchar-infos :format int16 :data char-info + :index (index+ 60 (index* 2 nfont-props 4))) + (setf (font-char-infos-internal font) char-info) + (setf (font-font-info-internal font) font-info))) ;; Replace atom id's with keywords in the plist (do ((p props (cddr p))) - ((endp p)) + ((endp p)) (setf (car p) (atom-name display (car p)))) (setf (font-info-properties font-info) props) font-info)) @@ -244,29 +244,29 @@ ;; counted locally. (declare (type font font)) (when (and (not (plusp (decf (font-reference-count font)))) - (font-id-internal font)) + (font-id-internal font)) (let ((display (font-display font)) - (id (font-id-internal font))) + (id (font-id-internal font))) (declare (type display display)) ;; Remove font from cache (setf (display-font-cache display) (delete font (display-font-cache display))) ;; Close the font (with-buffer-request (display +x-closefont+) - (resource-id id))))) + (resource-id id))))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type + (type string pattern) + (type card16 max-fonts) + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (let ((string (string pattern))) (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16)) - ((card16 max-fonts (length string)) - (string string)) + ((card16 max-fonts (length string)) + (string string)) (values - (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) + (read-sequence-string + buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) ;; Note: Was called list-fonts-with-info. @@ -276,92 +276,92 @@ ;; OpenFont request. However, the OpenFont might fail, in which case the ;; invalid-font error can arise. (declare (type display display) - (type string pattern) - (type card16 max-fonts) - (type t result-type)) ;; CL type + (type string pattern) + (type card16 max-fonts) + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence font))) (let ((string (string pattern)) - (result nil)) + (result nil)) (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60 - :sizes (8 16) :multiple-reply t) - ((card16 max-fonts (length string)) - (string string)) + :sizes (8 16) :multiple-reply t) + ((card16 max-fonts (length string)) + (string string)) (cond ((zerop (card8-get 1)) t) - (t - (let* ((name-len (card8-get 1)) - (min-byte2 (card16-get 40)) - (max-byte2 (card16-get 42)) - (min-byte1 (card8-get 49)) - (max-byte1 (card8-get 50)) - (min-char min-byte2) - (max-char (index+ (index-ash max-byte1 8) max-byte2)) - (nfont-props (card16-get 46)) - (font - (make-font - :display display - :name nil - :font-info-internal - (make-font-info - :direction (member8-get 48 :left-to-right :right-to-left) - :min-char min-char - :max-char max-char - :min-byte1 min-byte1 - :max-byte1 max-byte1 - :min-byte2 min-byte2 - :max-byte2 max-byte2 - :all-chars-exist-p (boolean-get 51) - :default-char (card16-get 44) - :ascent (int16-get 52) - :descent (int16-get 54) - :min-bounds (char-info-get 8) - :max-bounds (char-info-get 24) - :properties (sequence-get :length (index* 2 nfont-props) - :format int32 - :result-type 'list - :index 60))))) - (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) - (push font result)) - nil))) + (t + (let* ((name-len (card8-get 1)) + (min-byte2 (card16-get 40)) + (max-byte2 (card16-get 42)) + (min-byte1 (card8-get 49)) + (max-byte1 (card8-get 50)) + (min-char min-byte2) + (max-char (index+ (index-ash max-byte1 8) max-byte2)) + (nfont-props (card16-get 46)) + (font + (make-font + :display display + :name nil + :font-info-internal + (make-font-info + :direction (member8-get 48 :left-to-right :right-to-left) + :min-char min-char + :max-char max-char + :min-byte1 min-byte1 + :max-byte1 max-byte1 + :min-byte2 min-byte2 + :max-byte2 max-byte2 + :all-chars-exist-p (boolean-get 51) + :default-char (card16-get 44) + :ascent (int16-get 52) + :descent (int16-get 54) + :min-bounds (char-info-get 8) + :max-bounds (char-info-get 24) + :properties (sequence-get :length (index* 2 nfont-props) + :format int32 + :result-type 'list + :index 60))))) + (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) + (push font result)) + nil))) ;; Replace atom id's with keywords in the plist (dolist (font result) (do ((p (font-properties font) (cddr p))) - ((endp p)) - (setf (car p) (atom-name display (car p))))) + ((endp p)) + (setf (car p) (atom-name display (car p))))) (coerce (nreverse result) result-type))) (defun font-path (display &key (result-type 'list)) (declare (type display display) - (type t result-type)) ;; CL type + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence (or string pathname)))) (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16)) () (values (read-sequence-string - buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) + buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) (defun set-font-path (display paths) (declare (type display display) - (type (clx-sequence (or string pathname)) paths)) + (type (clx-sequence (or string pathname)) paths)) (let ((path-length (length paths)) - (request-length 8)) + (request-length 8)) ;; Find the request length (dotimes (i path-length) (let* ((string (string (elt paths i))) - (len (length string))) - (incf request-length (1+ len)))) + (len (length string))) + (incf request-length (1+ len)))) (with-buffer-request (display +x-setfontpath+ :length request-length) (length (ceiling request-length 4)) (card16 path-length) (pad16 nil) (progn - (incf buffer-boffset 8) - (dotimes (i path-length) - (let* ((string (string (elt paths i))) - (len (length string))) - (card8-put 0 len) - (string-put 1 string :appending t :header-length 1) - (incf buffer-boffset (1+ len)))) - (setf (buffer-boffset display) (lround buffer-boffset))))) + (incf buffer-boffset 8) + (dotimes (i path-length) + (let* ((string (string (elt paths i))) + (len (length string))) + (card8-put 0 len) + (string-put 1 string :appending t :header-length 1) + (incf buffer-boffset (1+ len)))) + (setf (buffer-boffset display) (lround buffer-boffset))))) paths) (defsetf font-path set-font-path) diff --git a/src/clx/gcontext.lisp b/src/clx/gcontext.lisp index 23d6a22ff..ea96aa867 100644 --- a/src/clx/gcontext.lisp +++ b/src/clx/gcontext.lisp @@ -3,9 +3,9 @@ ;;; GContext ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -18,71 +18,71 @@ ;;; express or implied warranty. ;;; -;;; GContext values are usually cached locally in the GContext object. -;;; This is required because the X.11 server doesn't have any requests -;;; for getting GContext values back. +;;; GContext values are usually cached locally in the GContext object. +;;; This is required because the X.11 server doesn't have any requests +;;; for getting GContext values back. ;;; -;;; GContext changes are cached until force-GContext-changes is called. -;;; All the requests that use GContext (including the GContext accessors, -;;; but not the SETF's) call force-GContext-changes. -;;; In addition, the macro WITH-GCONTEXT may be used to provide a -;;; local view if a GContext. +;;; GContext changes are cached until force-GContext-changes is called. +;;; All the requests that use GContext (including the GContext accessors, +;;; but not the SETF's) call force-GContext-changes. +;;; In addition, the macro WITH-GCONTEXT may be used to provide a +;;; local view if a GContext. ;;; -;;; Each GContext keeps a copy of the values the server has seen, and -;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). -;;; The SETF accessors increment a timestamp in the GContext. -;;; When the timestamp in a GContext isn't equal to the timestamp in -;;; the local-state, changes have been made, and force-GContext-changes -;;; loops through the GContext and local-state, sending differences to -;;; the server, and updating GContext. +;;; Each GContext keeps a copy of the values the server has seen, and +;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). +;;; The SETF accessors increment a timestamp in the GContext. +;;; When the timestamp in a GContext isn't equal to the timestamp in +;;; the local-state, changes have been made, and force-GContext-changes +;;; loops through the GContext and local-state, sending differences to +;;; the server, and updating GContext. ;;; -;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to -;;; a private copy. This is easy (and fast) for lisp machines, but other -;;; lisps will have problems. Fortunately, most other lisps don't care, -;;; because they don't run in a multi-processing shared-address space -;;; environment. +;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to +;;; a private copy. This is easy (and fast) for lisp machines, but other +;;; lisps will have problems. Fortunately, most other lisps don't care, +;;; because they don't run in a multi-processing shared-address space +;;; environment. (in-package :xlib) ;; GContext state accessors -;; The state vector contains all card32s to speed server updating +;; The state vector contains all card32s to speed server updating (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+)) (macrolet ((def-gc-internals (name &rest extras) - (let ((macros nil) - (indexes nil) - (masks nil) - (index 0)) - (dolist (name +gcontext-components+) - (push `(defmacro ,(xintern 'gcontext-internal- name) (state) - `(svref ,state ,,index)) - macros) - (setf (getf indexes name) index) - (push (ash 1 index) masks) - (incf index)) - (dolist (extra extras) - (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) - `(svref ,state ,,index)) - macros) - ;; don't override already correct index entries - (unless (or (getf indexes (second extra)) (getf indexes (first extra))) - (setf (getf indexes (or (second extra) (first extra))) index)) - (push (logior (ash 1 index) - (if (second extra) - (ash 1 (position (second extra) +gcontext-components+)) - 0)) - masks) - (incf index)) - `(within-definition (def-gc-internals ,name) - ,@(nreverse macros) - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *gcontext-data-length* ,index) - (defvar *gcontext-indexes* ',indexes) - (defvar *gcontext-masks* - ',(coerce (nreverse masks) 'simple-vector) - )))))) + (let ((macros nil) + (indexes nil) + (masks nil) + (index 0)) + (dolist (name +gcontext-components+) + (push `(defmacro ,(xintern 'gcontext-internal- name) (state) + `(svref ,state ,,index)) + macros) + (setf (getf indexes name) index) + (push (ash 1 index) masks) + (incf index)) + (dolist (extra extras) + (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) + `(svref ,state ,,index)) + macros) + ;; don't override already correct index entries + (unless (or (getf indexes (second extra)) (getf indexes (first extra))) + (setf (getf indexes (or (second extra) (first extra))) index)) + (push (logior (ash 1 index) + (if (second extra) + (ash 1 (position (second extra) +gcontext-components+)) + 0)) + masks) + (incf index)) + `(within-definition (def-gc-internals ,name) + ,@(nreverse macros) + (eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *gcontext-data-length* ,index) + (defvar *gcontext-indexes* ',indexes) + (defvar *gcontext-masks* + ',(coerce (nreverse masks) 'simple-vector) + )))))) (def-gc-internals ignore (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) @@ -98,13 +98,13 @@ ;; FIXME: these used to have glorious, but wrong, type declarations. ;; See if we can't return them to their former glory. (set-function #'(lambda (gcontext value) - (declare (ignore gcontext)) - value) - :type (or function symbol) :read-only t) + (declare (ignore gcontext)) + value) + :type (or function symbol) :read-only t) (copy-function #'(lambda (from-gc to-gc value) - (declare (ignore from-gc to-gc)) - value) - :type (or function symbol) :read-only t)) + (declare (ignore from-gc to-gc)) + value) + :type (or function symbol) :read-only t)) (defvar *gcontext-extensions* nil) ;; list of gcontext-extension @@ -122,17 +122,17 @@ (declare (type array-index length)) (loop (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* - gcontext-state-next gcontext-state) - (make-array length :initial-element nil)))) - (declare (type gcontext-state state)) - (when (index>= (length state) length) - (return state)))))) + gcontext-state-next gcontext-state) + (make-array length :initial-element nil)))) + (declare (type gcontext-state state)) + (when (index>= (length state) length) + (return state)))))) (defun deallocate-gcontext-state (state) (declare (type gcontext-state state)) (fill state nil) (threaded-atomic-push state *gcontext-local-state-cache* - gcontext-state-next gcontext-state)) + gcontext-state-next gcontext-state)) ;; Temp-Gcontext Resource (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts @@ -152,7 +152,7 @@ ; ;; The value will be nil if the last value stored is unknown (e.g., the cache was ; ;; off, or the component was copied from a gcontext with unknown state). ; (declare (type gcontext gcontext) -; (clx-values ))) +; (clx-values ))) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type (or null ) ), there is a setf for the corresponding accessor: @@ -175,39 +175,39 @@ `(let ((,local-state (gcontext-local-state ,gcontext))) (declare (type gcontext-state ,local-state)) (prog1 - (progn ,@body) + (progn ,@body) (setf (gcontext-internal-timestamp ,local-state) 0)))) (defmacro def-gc-accessor (name type) (let* ((gcontext-name (xintern 'gcontext- name)) - (internal-accessor (xintern 'gcontext-internal- name)) - (internal-setfer (xintern 'set- gcontext-name))) + (internal-accessor (xintern 'gcontext-internal- name)) + (internal-setfer (xintern 'set- gcontext-name))) `(within-definition (,name def-gc-accessor) (defun ,gcontext-name (gcontext) - (declare (type gcontext gcontext)) - (declare (clx-values (or null ,type))) - (let ((value (,internal-accessor (gcontext-local-state gcontext)))) - (declare (type (or null card32) value)) - (when value ;; Don't do anything when value isn't known - (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - %buffer - (decode-type ,type value))))) + (declare (type gcontext gcontext)) + (declare (clx-values (or null ,type))) + (let ((value (,internal-accessor (gcontext-local-state gcontext)))) + (declare (type (or null card32) value)) + (when value ;; Don't do anything when value isn't known + (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + %buffer + (decode-type ,type value))))) (defun ,internal-setfer (gcontext value) - (declare (type gcontext gcontext) - (type ,type value)) - (modify-gcontext (gcontext local-state) - (setf (,internal-accessor local-state) (encode-type ,type value)) - ,@(when (eq type 'pixmap) - ;; write-through pixmaps, because the protocol allows - ;; the server to copy the pixmap contents at the time - ;; of the store, rather than continuing to share with - ;; the pixmap. - `((let ((server-state (gcontext-server-state gcontext))) - (setf (,internal-accessor server-state) nil)))) - value)) + (declare (type gcontext gcontext) + (type ,type value)) + (modify-gcontext (gcontext local-state) + (setf (,internal-accessor local-state) (encode-type ,type value)) + ,@(when (eq type 'pixmap) + ;; write-through pixmaps, because the protocol allows + ;; the server to copy the pixmap contents at the time + ;; of the store, rather than continuing to share with + ;; the pixmap. + `((let ((server-state (gcontext-server-state gcontext))) + (setf (,internal-accessor server-state) nil)))) + value)) (defsetf ,gcontext-name ,internal-setfer)))) @@ -217,8 +217,8 @@ (declare (type fixnum ,ts)) ;; the probability seems low enough (setq ,ts (if (= ,ts most-positive-fixnum) - 1 - (the fixnum (1+ ,ts)))) + 1 + (the fixnum (1+ ,ts)))) (setf (gcontext-internal-timestamp ,state) ,ts)))) (def-gc-accessor function boole-constant) @@ -249,20 +249,20 @@ (defun gcontext-clip-mask (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null (member :none) pixmap rect-seq) - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) (access-gcontext (gcontext local-state) (multiple-value-bind (clip clip-mask) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip-mask local-state))) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip-mask local-state))) (if (null clip) - (values (let ((%buffer (gcontext-display gcontext))) - (declare (type display %buffer)) - (decode-type (or (member :none) pixmap) clip-mask)) - nil) - (values (second clip) - (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - (first clip))))))) + (values (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + (decode-type (or (member :none) pixmap) clip-mask)) + nil) + (values (second clip) + (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + (first clip))))))) (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) ;; A bit strange, but retains setf form. @@ -272,34 +272,34 @@ (defun set-gcontext-clip-mask (gcontext ordering clip-mask) ;; a nil clip-mask is transformed to an empty vector (declare (type gcontext gcontext) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) - (type (or (member :none) pixmap rect-seq) clip-mask)) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) + (type (or (member :none) pixmap rect-seq) clip-mask)) (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) (multiple-value-bind (clip-mask clip) (typecase clip-mask - (pixmap (values (pixmap-id clip-mask) nil)) - ((member :none) (values 0 nil)) - (sequence - (values nil - (list (encode-type - (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) - ordering) - (copy-seq clip-mask)))) - (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) + (pixmap (values (pixmap-id clip-mask) nil)) + ((member :none) (values 0 nil)) + (sequence + (values nil + (list (encode-type + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + ordering) + (copy-seq clip-mask)))) + (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-clip local-state) clip - (gcontext-internal-clip-mask local-state) clip-mask) - (if (null clip) - (setf (gcontext-internal-clip server-state) nil) - (setf (gcontext-internal-clip-mask server-state) nil)) - (when (and clip-mask (not (zerop clip-mask))) - ;; write-through clip-mask pixmap, because the protocol allows the - ;; server to copy the pixmap contents at the time of the store, - ;; rather than continuing to share with the pixmap. - (setf (gcontext-internal-clip-mask server-state) nil)))))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-clip local-state) clip + (gcontext-internal-clip-mask local-state) clip-mask) + (if (null clip) + (setf (gcontext-internal-clip server-state) nil) + (setf (gcontext-internal-clip-mask server-state) nil)) + (when (and clip-mask (not (zerop clip-mask))) + ;; write-through clip-mask pixmap, because the protocol allows the + ;; server to copy the pixmap contents at the time of the store, + ;; rather than continuing to share with the pixmap. + (setf (gcontext-internal-clip-mask server-state) nil)))))) clip-mask) (defun gcontext-dashes (gcontext) @@ -307,33 +307,33 @@ (declare (clx-values (or null card8 sequence))) (access-gcontext (gcontext local-state) (multiple-value-bind (dash dashes) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dashes local-state))) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dashes local-state))) (if (null dash) - dashes - dash)))) + dashes + dash)))) (defsetf gcontext-dashes set-gcontext-dashes) (defun set-gcontext-dashes (gcontext dashes) (declare (type gcontext gcontext) - (type (or card8 sequence) dashes)) + (type (or card8 sequence) dashes)) (multiple-value-bind (dashes dash) (if (type? dashes 'sequence) - (if (zerop (length dashes)) - (x-type-error dashes '(or card8 sequence) "non-empty sequence") - (values nil (or (copy-seq dashes) (vector)))) - (values (encode-type card8 dashes) nil)) + (if (zerop (length dashes)) + (x-type-error dashes '(or card8 sequence) "non-empty sequence") + (values nil (or (copy-seq dashes) (vector)))) + (values (encode-type card8 dashes) nil)) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-dash local-state) dash - (gcontext-internal-dashes local-state) dashes) - (if (null dash) - (setf (gcontext-internal-dash server-state) nil) - (setf (gcontext-internal-dashes server-state) nil)))))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-dash local-state) dash + (gcontext-internal-dashes local-state) dashes) + (if (null dash) + (setf (gcontext-internal-dash server-state) nil) + (setf (gcontext-internal-dashes server-state) nil)))))) dashes) (defun gcontext-font (gcontext &optional metrics-p) @@ -344,35 +344,35 @@ ;; a resource-id, and attempts to use it where a resource-id is required will ;; result in an invalid-font error. (declare (type gcontext gcontext) - (type generalized-boolean metrics-p)) + (type generalized-boolean metrics-p)) (declare (clx-values (or null font))) (access-gcontext (gcontext local-state) (let ((font (gcontext-internal-font-obj local-state))) (or font - (when metrics-p - ;; XXX this isn't correct - (make-font :display (gcontext-display gcontext) - :id (gcontext-id gcontext) - :name nil)))))) + (when metrics-p + ;; XXX this isn't correct + (make-font :display (gcontext-display gcontext) + :id (gcontext-id gcontext) + :name nil)))))) (defsetf gcontext-font set-gcontext-font) (defun set-gcontext-font (gcontext font) (declare (type gcontext gcontext) - (type fontable font)) + (type fontable font)) (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) - (font (and font-object (font-id font-object)))) + (font (and font-object (font-id font-object)))) ;; XXX need to check font has id (and name?) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state server-state)) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font-object - (gcontext-internal-font local-state) font) - ;; check against font, not against font-obj - (if (null font) - (setf (gcontext-internal-font server-state) nil) - (setf (gcontext-internal-font-obj server-state) font-object)))))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font-object + (gcontext-internal-font local-state) font) + ;; check against font, not against font-obj + (if (null font) + (setf (gcontext-internal-font server-state) nil) + (setf (gcontext-internal-font-obj server-state) font-object)))))) font) (defun force-gcontext-changes-internal (gcontext) @@ -381,126 +381,126 @@ #.(declare-buffun) (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) (declare (type display display) - (type gcontext-state server-state local-state)) + (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) + (the fixnum (gcontext-internal-timestamp server-state))) ;; The display is already locked. (macrolet ((with-buffer ((buffer &key timeout) &body body) - `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) - ,@body))) + `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) - ;; Because there is no locking on the local state we have to - ;; assume that state will change and set timestamps up front, - ;; otherwise by the time we figured out there were no changes - ;; and tried to store the server stamp as the local stamp, the - ;; local stamp might have since been modified. - (setf (gcontext-internal-timestamp local-state) - (incf-internal-timestamp server-state)) + ;; Because there is no locking on the local state we have to + ;; assume that state will change and set timestamps up front, + ;; otherwise by the time we figured out there were no changes + ;; and tried to store the server stamp as the local stamp, the + ;; local stamp might have since been modified. + (setf (gcontext-internal-timestamp local-state) + (incf-internal-timestamp server-state)) - (block no-changes - (let ((last-request (buffer-last-request display))) - (with-buffer-request (display +x-changegc+) - (gcontext gcontext) - (progn - (do ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 12) - (mask 0) - (local 0)) - ((index>= i +gcontext-fast-change-length+) - (when (zerop mask) - ;; If nothing changed, restore last-request and quit - (setf (buffer-last-request display) - (if (zerop (buffer-last-request display)) - nil - last-request)) - (return-from no-changes nil)) - (card29-put 8 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql (the (or null card32) (svref server-state i)) - (setq local (the (or null card32) (svref local-state i)))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))))) + (block no-changes + (let ((last-request (buffer-last-request display))) + (with-buffer-request (display +x-changegc+) + (gcontext gcontext) + (progn + (do ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 12) + (mask 0) + (local 0)) + ((index>= i +gcontext-fast-change-length+) + (when (zerop mask) + ;; If nothing changed, restore last-request and quit + (setf (buffer-last-request display) + (if (zerop (buffer-last-request display)) + nil + last-request)) + (return-from no-changes nil)) + (card29-put 8 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql (the (or null card32) (svref server-state i)) + (setq local (the (or null card32) (svref local-state i)))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))))) - ;; Update GContext extensions - (do ((extension *gcontext-extensions* (cdr extension)) - (i *gcontext-data-length* (index+ i 1)) - (local)) - ((endp extension)) - (unless (eql (svref server-state i) - (setq local (svref local-state i))) - (setf (svref server-state i) local) - (funcall (gcontext-extension-set-function (car extension)) gcontext local))) + ;; Update GContext extensions + (do ((extension *gcontext-extensions* (cdr extension)) + (i *gcontext-data-length* (index+ i 1)) + (local)) + ((endp extension)) + (unless (eql (svref server-state i) + (setq local (svref local-state i))) + (setf (svref server-state i) local) + (funcall (gcontext-extension-set-function (car extension)) gcontext local))) - ;; Update clipping rectangles - (multiple-value-bind (local-clip server-clip) - (without-interrupts - (values (gcontext-internal-clip local-state) - (gcontext-internal-clip server-state))) - (unless (equalp local-clip server-clip) - (setf (gcontext-internal-clip server-state) nil) - (unless (null local-clip) - (with-buffer-request (display +x-setcliprectangles+) - (data (first local-clip)) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-clip-x local-state) 0) - (or (gcontext-internal-clip-y local-state) 0)) - ;; XXX this has both int16 and card16 values - ((sequence :format int16) (second local-clip))) - (setf (gcontext-internal-clip server-state) local-clip)))) + ;; Update clipping rectangles + (multiple-value-bind (local-clip server-clip) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip server-state))) + (unless (equalp local-clip server-clip) + (setf (gcontext-internal-clip server-state) nil) + (unless (null local-clip) + (with-buffer-request (display +x-setcliprectangles+) + (data (first local-clip)) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-clip-x local-state) 0) + (or (gcontext-internal-clip-y local-state) 0)) + ;; XXX this has both int16 and card16 values + ((sequence :format int16) (second local-clip))) + (setf (gcontext-internal-clip server-state) local-clip)))) - ;; Update dashes - (multiple-value-bind (local-dash server-dash) - (without-interrupts - (values (gcontext-internal-dash local-state) - (gcontext-internal-dash server-state))) - (unless (equalp local-dash server-dash) - (setf (gcontext-internal-dash server-state) nil) - (unless (null local-dash) - (with-buffer-request (display +x-setdashes+) - (gcontext gcontext) - ;; XXX treat nil correctly - (card16 (or (gcontext-internal-dash-offset local-state) 0) - (length local-dash)) - ((sequence :format card8) local-dash)) - (setf (gcontext-internal-dash server-state) local-dash)))))))) + ;; Update dashes + (multiple-value-bind (local-dash server-dash) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dash server-state))) + (unless (equalp local-dash server-dash) + (setf (gcontext-internal-dash server-state) nil) + (unless (null local-dash) + (with-buffer-request (display +x-setdashes+) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-dash-offset local-state) 0) + (length local-dash)) + ((sequence :format card8) local-dash)) + (setf (gcontext-internal-dash server-state) local-dash)))))))) (defun force-gcontext-changes (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext)) - (server-state (gcontext-server-state gcontext)) - (local-state (gcontext-local-state gcontext))) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) (declare (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) - (the fixnum (gcontext-internal-timestamp server-state))) + (the fixnum (gcontext-internal-timestamp server-state))) (with-display (display) - (force-gcontext-changes-internal gcontext))))) + (force-gcontext-changes-internal gcontext))))) ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE -;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN -;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN -;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS +;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN +;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN +;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS ;;; BACK. (defmacro with-gcontext ((gcontext &rest options &key clip-ordering - &allow-other-keys) - &body body) + &allow-other-keys) + &body body) ;; "Binds" the gcontext components specified by options within the ;; dynamic scope of the body (i.e., indefinite scope and dynamic ;; extent), on a per-process basis in a multi-process environment. @@ -510,165 +510,165 @@ ;; copy-gcontext-components to and from it. (declare (arglist (gcontext &rest options &key - function plane-mask foreground background - line-width line-style cap-style join-style - fill-style fill-rule arc-mode tile stipple ts-x - ts-y font subwindow-mode exposures clip-x clip-y - clip-mask clip-ordering dash-offset dashes - &allow-other-keys) - &body body)) + function plane-mask foreground background + line-width line-style cap-style join-style + fill-style fill-rule arc-mode tile stipple ts-x + ts-y font subwindow-mode exposures clip-x clip-y + clip-mask clip-ordering dash-offset dashes + &allow-other-keys) + &body body)) (remf options :clip-ordering) (let ((gc (gensym)) - (saved-state (gensym)) - (temp-gc (gensym)) - (temp-mask (gensym)) - (temp-vars nil) - (setfs nil) - (indexes nil) ; List of gcontext field indices - (extension-indexes nil) ; List of gcontext extension field indices - (ts-index (getf *gcontext-indexes* :timestamp))) + (saved-state (gensym)) + (temp-gc (gensym)) + (temp-mask (gensym)) + (temp-vars nil) + (setfs nil) + (indexes nil) ; List of gcontext field indices + (extension-indexes nil) ; List of gcontext extension field indices + (ts-index (getf *gcontext-indexes* :timestamp))) (do* ((option options (cddr option)) - (name (car option) (car option)) - (value (cadr option) (cadr option))) - ((endp option) (setq setfs (nreverse setfs))) + (name (car option) (car option)) + (value (cadr option) (cadr option))) + ((endp option) (setq setfs (nreverse setfs))) (let ((index (getf *gcontext-indexes* name))) - (if index - (push index indexes) - (let ((extension (find name *gcontext-extensions* - :key #'gcontext-extension-name))) - (if extension - (progn - (push (xintern "Internal-" 'gcontext- name "-State-Index") - extension-indexes)) - (x-type-error name 'gcontext-key))))) + (if index + (push index indexes) + (let ((extension (find name *gcontext-extensions* + :key #'gcontext-extension-name))) + (if extension + (progn + (push (xintern "Internal-" 'gcontext- name "-State-Index") + extension-indexes)) + (x-type-error name 'gcontext-key))))) (let ((accessor `(,(xintern 'gcontext- name) ,gc - ,@(when (eq name :clip-mask) `(,clip-ordering)))) - (temp-var (gensym))) - (when value - (push `(,temp-var ,value) temp-vars) - (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) + ,@(when (eq name :clip-mask) `(,clip-ordering)))) + (temp-var (gensym))) + (when value + (push `(,temp-var ,value) temp-vars) + (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) (if setfs - `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) - (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) - (declare (type gcontext ,gc) - (type gcontext-state ,saved-state) - (type xgcmask ,temp-mask) - (type (or null gcontext) ,temp-gc)) - (with-gcontext-bindings (,gc ,saved-state - ,(append indexes extension-indexes) - ,ts-index ,temp-mask ,temp-gc) - (let ,temp-vars - ,@setfs) - ,@body)) + `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) + (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) + (declare (type gcontext ,gc) + (type gcontext-state ,saved-state) + (type xgcmask ,temp-mask) + (type (or null gcontext) ,temp-gc)) + (with-gcontext-bindings (,gc ,saved-state + ,(append indexes extension-indexes) + ,ts-index ,temp-mask ,temp-gc) + (let ,temp-vars + ,@setfs) + ,@body)) `(progn ,@body)))) (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK (declare (type gcontext gcontext) - (type list indexes) - (dynamic-extent extension-indices)) + (type list indexes) + (dynamic-extent extension-indices)) (let ((local-state (gcontext-local-state gcontext)) - (saved-state (allocate-gcontext-state)) - (cache-p (gcontext-cache-p gcontext))) + (saved-state (allocate-gcontext-state)) + (cache-p (gcontext-cache-p gcontext))) (declare (type gcontext-state local-state saved-state)) (setf (gcontext-internal-timestamp saved-state) 1) (let ((temp-gc nil) - (temp-mask 0) - (extension-mask 0)) + (temp-mask 0) + (extension-mask 0)) (declare (type xgcmask temp-mask) - (type integer extension-mask)) + (type integer extension-mask)) (dolist (i indexes) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq temp-mask - (the xgcmask (logior temp-mask - (the xgcmask (svref *gcontext-masks* i))))))) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq temp-mask + (the xgcmask (logior temp-mask + (the xgcmask (svref *gcontext-masks* i))))))) (dolist (i extension-indices) - (when (or (not (setf (svref saved-state i) (svref local-state i))) - (not cache-p)) - (setq extension-mask - (the xgcmask (logior extension-mask (ash 1 i)))))) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq extension-mask + (the xgcmask (logior extension-mask (ash 1 i)))))) (when (or (plusp temp-mask) - (plusp extension-mask)) - ;; Copy to temporary GC when field unknown or cache-p false - (let ((display (gcontext-display gcontext))) - (declare (type display display)) - (with-display (display) - (setq temp-gc (allocate-temp-gcontext)) - (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) - (gcontext-display temp-gc) display - (gcontext-drawable temp-gc) (gcontext-drawable gcontext) - (gcontext-server-state temp-gc) saved-state - (gcontext-local-state temp-gc) saved-state) - ;; Create a new (temporary) gcontext - (with-buffer-request (display +x-creategc+) - (gcontext temp-gc) - (drawable (gcontext-drawable gcontext)) - (card29 0)) - ;; Copy changed components to the temporary gcontext - (when (plusp temp-mask) - (with-buffer-request (display +x-copygc+) - (gcontext gcontext) - (gcontext temp-gc) - (card29 (xgcmask->gcmask temp-mask)))) - ;; Copy extension fields to the new gcontext - (when (plusp extension-mask) - ;; Copy extension fields from temp back to gcontext - (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) - (i 0 (index+ i 1))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function - (elt *gcontext-extensions* i)))) - (funcall copy-function gcontext temp-gc - (svref local-state (index+ i *gcontext-data-length*)))))) - ))) + (plusp extension-mask)) + ;; Copy to temporary GC when field unknown or cache-p false + (let ((display (gcontext-display gcontext))) + (declare (type display display)) + (with-display (display) + (setq temp-gc (allocate-temp-gcontext)) + (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) + (gcontext-display temp-gc) display + (gcontext-drawable temp-gc) (gcontext-drawable gcontext) + (gcontext-server-state temp-gc) saved-state + (gcontext-local-state temp-gc) saved-state) + ;; Create a new (temporary) gcontext + (with-buffer-request (display +x-creategc+) + (gcontext temp-gc) + (drawable (gcontext-drawable gcontext)) + (card29 0)) + ;; Copy changed components to the temporary gcontext + (when (plusp temp-mask) + (with-buffer-request (display +x-copygc+) + (gcontext gcontext) + (gcontext temp-gc) + (card29 (xgcmask->gcmask temp-mask)))) + ;; Copy extension fields to the new gcontext + (when (plusp extension-mask) + ;; Copy extension fields from temp back to gcontext + (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) + (i 0 (index+ i 1))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function + (elt *gcontext-extensions* i)))) + (funcall copy-function gcontext temp-gc + (svref local-state (index+ i *gcontext-data-length*)))))) + ))) (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) (declare (type gcontext gcontext temp-gc) - (type xgcmask temp-mask)) + (type xgcmask temp-mask)) (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) (with-buffer-request (display +x-copygc+) - (gcontext temp-gc) - (gcontext gcontext) - (card29 (xgcmask->gcmask temp-mask))) + (gcontext temp-gc) + (gcontext gcontext) + (card29 (xgcmask->gcmask temp-mask))) ;; Copy extension fields from temp back to gcontext (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) - (extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1)) - (local-state (gcontext-local-state temp-gc))) - ((zerop bit)) - (let ((copy-function (gcontext-extension-copy-function (car extensions)))) - (funcall copy-function temp-gc gcontext (svref local-state i)))) + (extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1)) + (local-state (gcontext-local-state temp-gc))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function (car extensions)))) + (funcall copy-function temp-gc gcontext (svref local-state i)))) ;; free gcontext (with-buffer-request (display +x-freegc+) - (gcontext temp-gc)) + (gcontext temp-gc)) (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) (deallocate-temp-gcontext temp-gc) ;; Copy saved state back to server state (do ((server-state (gcontext-server-state gcontext)) - (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp server-state)) - (declare (type gcontext-state server-state) - (type gcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref server-state i) nil)))))) + (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp server-state)) + (declare (type gcontext-state server-state) + (type gcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref server-state i) nil)))))) (defun create-gcontext (&rest options &key (drawable (required-arg drawable)) - function plane-mask foreground background - line-width line-style cap-style join-style fill-style fill-rule - arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y clip-mask clip-ordering - dash-offset dashes - (cache-p t) - &allow-other-keys) + function plane-mask foreground background + line-width line-style cap-style join-style fill-style fill-rule + arc-mode tile stipple ts-x ts-y font subwindow-mode + exposures clip-x clip-y clip-mask clip-ordering + dash-offset dashes + (cache-p t) + &allow-other-keys) ;; Only non-nil components are passed on in the request, but for effective caching ;; assumptions have to be made about what the actual protocol defaults are. For ;; all gcontext components, a value of nil causes the default gcontext value to be @@ -681,35 +681,35 @@ ;; regardless of the cache mode, and sent over the protocol only when required by a ;; local operation or by an explicit call to force-gcontext-changes. (declare (type drawable drawable) ; Required to be non-null - (type (or null boole-constant) function) - (type (or null pixel) plane-mask foreground background) - (type (or null card16) line-width dash-offset) - (type (or null int16) ts-x ts-y clip-x clip-y) - (type (or null (member :solid :dash :double-dash)) line-style) - (type (or null (member :not-last :butt :round :projecting)) cap-style) - (type (or null (member :miter :round :bevel)) join-style) - (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) - (type (or null (member :even-odd :winding)) fill-rule) - (type (or null (member :chord :pie-slice)) arc-mode) - (type (or null pixmap) tile stipple) - (type (or null fontable) font) - (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) - (type (or null (member :on :off)) exposures) - (type (or null (member :none) pixmap rect-seq) clip-mask) - (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) - (type (or null card8 sequence) dashes) - (dynamic-extent options) - (type generalized-boolean cache-p)) + (type (or null boole-constant) function) + (type (or null pixel) plane-mask foreground background) + (type (or null card16) line-width dash-offset) + (type (or null int16) ts-x ts-y clip-x clip-y) + (type (or null (member :solid :dash :double-dash)) line-style) + (type (or null (member :not-last :butt :round :projecting)) cap-style) + (type (or null (member :miter :round :bevel)) join-style) + (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) + (type (or null (member :even-odd :winding)) fill-rule) + (type (or null (member :chord :pie-slice)) arc-mode) + (type (or null pixmap) tile stipple) + (type (or null fontable) font) + (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) + (type (or null (member :on :off)) exposures) + (type (or null (member :none) pixmap rect-seq) clip-mask) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) + (type (or null card8 sequence) dashes) + (dynamic-extent options) + (type generalized-boolean cache-p)) (declare (clx-values gcontext)) (let* ((display (drawable-display drawable)) - (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) - (local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext)) - (gcontextid (allocate-resource-id display gcontext 'gcontext))) + (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) + (local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext)) + (gcontextid (allocate-resource-id display gcontext 'gcontext))) (declare (type display display) - (type gcontext gcontext) - (type resource-id gcontextid) - (type gcontext-state local-state server-state)) + (type gcontext gcontext) + (type resource-id gcontextid) + (type gcontext-state local-state server-state)) (setf (gcontext-id gcontext) gcontextid) (unless function (setf (gcontext-function gcontext) boole-1)) @@ -727,7 +727,7 @@ (unless ts-x (setf (gcontext-ts-x gcontext) 0)) (unless ts-y (setf (gcontext-ts-y gcontext) 0)) (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) - :clip-by-children)) + :clip-by-children)) (unless exposures (setf (gcontext-exposures gcontext) :on)) (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) (unless clip-x (setf (gcontext-clip-x gcontext) 0)) @@ -763,65 +763,65 @@ (setf (gcontext-internal-timestamp server-state) 1) (setf (gcontext-internal-timestamp local-state) - ;; SetClipRectangles or SetDashes request need to be sent? - (if (or (gcontext-internal-clip local-state) - (gcontext-internal-dash local-state)) - ;; Yes, mark local state "modified" to ensure - ;; force-gcontext-changes will occur. - 0 - ;; No, mark local state "unmodified" - 1)) + ;; SetClipRectangles or SetDashes request need to be sent? + (if (or (gcontext-internal-clip local-state) + (gcontext-internal-dash local-state)) + ;; Yes, mark local state "modified" to ensure + ;; force-gcontext-changes will occur. + 0 + ;; No, mark local state "unmodified" + 1)) (with-buffer-request (display +x-creategc+) (resource-id gcontextid) (drawable drawable) (progn (do* ((i 0 (index+ i 1)) - (bit 1 (the xgcmask (ash bit 1))) - (nbyte 16) - (mask 0) - (local (svref local-state i) (svref local-state i))) - ((index>= i +gcontext-fast-change-length+) - (card29-put 12 mask) - (card16-put 2 (index-ash nbyte -2)) - (index-incf (buffer-boffset display) nbyte)) - (declare (type array-index i nbyte) - (type xgcmask bit) - (type gcmask mask) - (type (or null card32) local)) - (unless (eql local (the (or null card32) (svref server-state i))) - (setf (svref server-state i) local) - (card32-put nbyte local) - (setq mask (the gcmask (logior mask bit))) - (index-incf nbyte 4))))) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 16) + (mask 0) + (local (svref local-state i) (svref local-state i))) + ((index>= i +gcontext-fast-change-length+) + (card29-put 12 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql local (the (or null card32) (svref server-state i))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))) ;; Initialize extensions (do ((extensions *gcontext-extensions* (cdr extensions)) - (i *gcontext-data-length* (index+ i 1))) - ((endp extensions)) + (i *gcontext-data-length* (index+ i 1))) + ((endp extensions)) (declare (type list extensions) - (type array-index i)) + (type array-index i)) (setf (svref server-state i) - (setf (svref local-state i) - (gcontext-extension-default (car extensions))))) + (setf (svref local-state i) + (gcontext-extension-default (car extensions))))) ;; Set extension values (do* ((option-list options (cddr option-list)) - (option (car option-list) (car option-list)) - (extension)) - ((endp option-list)) + (option (car option-list) (car option-list)) + (extension)) + ((endp option-list)) (declare (type list option-list)) - (cond ((getf *gcontext-indexes* option)) ; Gcontext field - ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter - ((setq extension (find option *gcontext-extensions* - :key #'gcontext-extension-name)) - (funcall (gcontext-extension-set-function extension) - gcontext (second option-list))) - (t (x-type-error option 'gcontext-key)))) + (cond ((getf *gcontext-indexes* option)) ; Gcontext field + ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter + ((setq extension (find option *gcontext-extensions* + :key #'gcontext-extension-name)) + (funcall (gcontext-extension-set-function extension) + gcontext (second option-list))) + (t (x-type-error option 'gcontext-key)))) gcontext)) (defun copy-gcontext-components (src dst &rest keys) (declare (type gcontext src dst) - (dynamic-extent keys)) + (dynamic-extent keys)) ;; you might ask why this isn't just a bunch of ;; (setf (gcontext- dst) (gcontext- src)) ;; the answer is that you can do that yourself if you want, what we are @@ -829,44 +829,44 @@ ;; be more efficient (particularly for things like clip and dash lists). (when keys (let ((display (gcontext-display src)) - (mask 0)) + (mask 0)) (declare (type xgcmask mask)) (with-display (display) - (force-gcontext-changes-internal src) - (force-gcontext-changes-internal dst) - - ;; collect entire mask and handle extensions - (dolist (key keys) - (let ((i (getf *gcontext-indexes* key))) - (declare (type (or null array-index) i)) - (if i - (setq mask (the xgcmask (logior mask - (the xgcmask (svref *gcontext-masks* i))))) - (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) - (if extension - (funcall (gcontext-extension-copy-function extension) - src dst (svref (gcontext-local-state src) - (index+ (position extension *gcontext-extensions*) *gcontext-data-length*))) - (x-type-error key 'gcontext-key)))))) - - (when (plusp mask) - (do ((src-server-state (gcontext-server-state src)) - (dst-server-state (gcontext-server-state dst)) - (dst-local-state (gcontext-local-state dst)) - (bit mask (the xgcmask (ash bit -1))) - (i 0 (index+ i 1))) - ((zerop bit) - (incf-internal-timestamp dst-server-state) - (setf (gcontext-internal-timestamp dst-local-state) 0)) - (declare (type gcontext-state src-server-state dst-server-state dst-local-state) - (type xgcmask bit) - (type array-index i)) - (when (oddp bit) - (setf (svref dst-local-state i) - (setf (svref dst-server-state i) (svref src-server-state i))))) - (with-buffer-request (display +x-copygc+) - (gcontext src dst) - (card29 (xgcmask->gcmask mask)))))))) + (force-gcontext-changes-internal src) + (force-gcontext-changes-internal dst) + + ;; collect entire mask and handle extensions + (dolist (key keys) + (let ((i (getf *gcontext-indexes* key))) + (declare (type (or null array-index) i)) + (if i + (setq mask (the xgcmask (logior mask + (the xgcmask (svref *gcontext-masks* i))))) + (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) + (if extension + (funcall (gcontext-extension-copy-function extension) + src dst (svref (gcontext-local-state src) + (index+ (position extension *gcontext-extensions*) *gcontext-data-length*))) + (x-type-error key 'gcontext-key)))))) + + (when (plusp mask) + (do ((src-server-state (gcontext-server-state src)) + (dst-server-state (gcontext-server-state dst)) + (dst-local-state (gcontext-local-state dst)) + (bit mask (the xgcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp dst-server-state) + (setf (gcontext-internal-timestamp dst-local-state) 0)) + (declare (type gcontext-state src-server-state dst-server-state dst-local-state) + (type xgcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref dst-local-state i) + (setf (svref dst-server-state i) (svref src-server-state i))))) + (with-buffer-request (display +x-copygc+) + (gcontext src dst) + (card29 (xgcmask->gcmask mask)))))))) (defun copy-gcontext (src dst) (declare (type gcontext src dst)) @@ -876,8 +876,8 @@ (i *gcontext-data-length* (index+ i 1))) ((endp extensions)) (funcall (gcontext-extension-copy-function (car extensions)) - src dst (svref (gcontext-local-state src) i)))) - + src dst (svref (gcontext-local-state src) i)))) + (defun free-gcontext (gcontext) (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext))) @@ -901,50 +901,50 @@ ;; The copy-function defaults to: ;; (lambda (ignore dst-gc value) ;; (if value - ;; (,set-function dst-gc value) - ;; (error "Can't copy unknown GContext component ~a" ',name))) + ;; (,set-function dst-gc value) + ;; (error "Can't copy unknown GContext component ~a" ',name))) (declare (type symbol name) - (type t default) - (type symbol set-function) ;; required - (type (or symbol list) copy-function)) + (type t default) + (type symbol set-function) ;; required + (type (or symbol list) copy-function)) (let* ((gc-name (intern (concatenate 'string - (string 'gcontext-) - (string name)))) ;; in current package - (key-name (kintern name)) - (setfer (xintern "Set-" gc-name)) - (internal-set-function (xintern "Internal-Set-" gc-name)) - (internal-copy-function (xintern "Internal-Copy-" gc-name)) - (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) + (string 'gcontext-) + (string name)))) ;; in current package + (key-name (kintern name)) + (setfer (xintern "Set-" gc-name)) + (internal-set-function (xintern "Internal-Set-" gc-name)) + (internal-copy-function (xintern "Internal-Copy-" gc-name)) + (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) (unless copy-function (setq copy-function - `(lambda (src-gc dst-gc value) - (declare (ignore src-gc)) - (if value - (,set-function dst-gc value) - (error "Can't copy unknown GContext component ~a" ',name))))) + `(lambda (src-gc dst-gc value) + (declare (ignore src-gc)) + (if value + (,set-function dst-gc value) + (error "Can't copy unknown GContext component ~a" ',name))))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,internal-state-index - (add-gcontext-extension ',key-name ,default ',internal-set-function - ',internal-copy-function)) - ) ;; end eval-when + (defparameter ,internal-state-index + (add-gcontext-extension ',key-name ,default ',internal-set-function + ',internal-copy-function)) + ) ;; end eval-when (defun ,gc-name (gcontext) - (svref (gcontext-local-state gcontext) ,internal-state-index)) + (svref (gcontext-local-state gcontext) ,internal-state-index)) (defun ,setfer (gcontext new-value) - (let ((local-state (gcontext-local-state gcontext))) - (setf (gcontext-internal-timestamp local-state) 0) - (setf (svref local-state ,internal-state-index) new-value))) + (let ((local-state (gcontext-local-state gcontext))) + (setf (gcontext-internal-timestamp local-state) 0) + (setf (svref local-state ,internal-state-index) new-value))) (defsetf ,gc-name ,setfer) (defun ,internal-set-function (gcontext new-value) - (,set-function gcontext new-value) - (setf (svref (gcontext-server-state gcontext) ,internal-state-index) - (setf (svref (gcontext-local-state gcontext) ,internal-state-index) - new-value))) + (,set-function gcontext new-value) + (setf (svref (gcontext-server-state gcontext) ,internal-state-index) + (setf (svref (gcontext-local-state gcontext) ,internal-state-index) + new-value))) (defun ,internal-copy-function (src-gc dst-gc new-value) - (,copy-function src-gc dst-gc new-value) - (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) - (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) - new-value))) + (,copy-function src-gc dst-gc new-value) + (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) + (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) + new-value))) ',name))) ;; GContext extension fields are treated in much the same way as normal GContext @@ -958,15 +958,15 @@ (defun add-gcontext-extension (name default-value set-function copy-function) (declare (type symbol name) - (type t default-value) - (type (or function symbol) set-function) - (type (or function symbol) copy-function)) + (type t default-value) + (type (or function symbol) set-function) + (type (or function symbol) copy-function)) (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) - (prog1 (length *gcontext-extensions*) - (push nil *gcontext-extensions*))))) + (prog1 (length *gcontext-extensions*) + (push nil *gcontext-extensions*))))) (setf (nth number *gcontext-extensions*) - (make-gcontext-extension :name name - :default default-value - :set-function set-function - :copy-function copy-function)) + (make-gcontext-extension :name name + :default default-value + :set-function set-function + :copy-function copy-function)) (+ number *gcontext-data-length*))) diff --git a/src/clx/generalock.lisp b/src/clx/generalock.lisp index cbf95a38a..6ff14d61a 100644 --- a/src/clx/generalock.lisp +++ b/src/clx/generalock.lisp @@ -24,49 +24,49 @@ (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) (let ((process (lock-argument-process lock-argument))) (unwind-protect - (progn - (lock-map-over-conflicting-owners - self lock-argument - #'(lambda (other-lock-arg) - (add-promotion process lock-argument - (lock-argument-process other-lock-arg) other-lock-arg))) - (unless (timer-pending-p timer) - (when (and (safe-to-use-timers %real-current-process) - (not dbg:*debugger-might-have-system-problems*)) - (reset-timer-relative-timer-units timer *lock-timer-interval*))) - (assert (store-conditional (locf latch) process nil)) - (sys:with-aborts-enabled (lock-latch) - (let ((timeout (lock-argument-getf lock-argument :timeout nil))) - (cond ((null timeout) - (promotion-block waiter-queue name #'lock-lockable self lock-argument)) - ((and (plusp timeout) - (using-resource (timer process-block-timers) - ;; Yeah, we know about the internal representation - ;; of timers here. - (setf (car (timer-args timer)) %real-current-process) - (with-scheduler-locked - (reset-timer-relative timer timeout) - (flet ((lock-lockable-or-timeout (timer lock lock-argument) - (or (not (timer-pending-p timer)) - (lock-lockable lock lock-argument)))) - (let ((priority (process-process-priority *current-process*))) - (if (ldb-test %%scheduler-priority-preemption-field priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument) - ;; Change to preemptive priority so that when - ;; unlock-internal wakes us up so we can have the lock, - ;; we will really wake up right away - (with-process-priority - (dpb 1 %%scheduler-priority-preemption-field - priority) - (promotion-block waiter-queue name - #'lock-lockable-or-timeout - timer self lock-argument))))) - (lock-lockable self lock-argument))))) - (t (throw 'timeout nil)))))) + (progn + (lock-map-over-conflicting-owners + self lock-argument + #'(lambda (other-lock-arg) + (add-promotion process lock-argument + (lock-argument-process other-lock-arg) other-lock-arg))) + (unless (timer-pending-p timer) + (when (and (safe-to-use-timers %real-current-process) + (not dbg:*debugger-might-have-system-problems*)) + (reset-timer-relative-timer-units timer *lock-timer-interval*))) + (assert (store-conditional (locf latch) process nil)) + (sys:with-aborts-enabled (lock-latch) + (let ((timeout (lock-argument-getf lock-argument :timeout nil))) + (cond ((null timeout) + (promotion-block waiter-queue name #'lock-lockable self lock-argument)) + ((and (plusp timeout) + (using-resource (timer process-block-timers) + ;; Yeah, we know about the internal representation + ;; of timers here. + (setf (car (timer-args timer)) %real-current-process) + (with-scheduler-locked + (reset-timer-relative timer timeout) + (flet ((lock-lockable-or-timeout (timer lock lock-argument) + (or (not (timer-pending-p timer)) + (lock-lockable lock lock-argument)))) + (let ((priority (process-process-priority *current-process*))) + (if (ldb-test %%scheduler-priority-preemption-field priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument) + ;; Change to preemptive priority so that when + ;; unlock-internal wakes us up so we can have the lock, + ;; we will really wake up right away + (with-process-priority + (dpb 1 %%scheduler-priority-preemption-field + priority) + (promotion-block waiter-queue name + #'lock-lockable-or-timeout + timer self lock-argument))))) + (lock-lockable self lock-argument))))) + (t (throw 'timeout nil)))))) (unless (store-conditional (locf latch) nil process) - (lock-latch-wait-internal self)) + (lock-latch-wait-internal self)) (remove-promotions process lock-argument)))) (compile-flavor-methods xlib::clx-lock) diff --git a/src/clx/graphics.lisp b/src/clx/graphics.lisp index 9f3f327ed..dec658067 100644 --- a/src/clx/graphics.lisp +++ b/src/clx/graphics.lisp @@ -3,9 +3,9 @@ ;;; CLX drawing requests ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -25,59 +25,59 @@ (defun draw-point (drawable gcontext x y) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y)) + (type gcontext gcontext) + (type int16 x y)) (let ((display (drawable-display drawable))) (declare (type display display)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (data 0) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y)) - (setf (display-boffset display) (index+ buffer-boffset 4))) - ;; New Request - (progn - (put-items (4) - (code +x-polypoint+) - (data 0) ;; Relative-p false - (length 4) - (drawable drawable) - (gcontext gcontext) - (int16 x y)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 16))))))) + (let* ((last-request-byte (display-last-request display)) + (current-boffset buffer-boffset)) + ;; To append or not append, that is the question + (if (and (not *inhibit-appending*) + last-request-byte + ;; Same request? + (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) + (progn ;; Set buffer pointers to last request + (set-buffer-offset last-request-byte) + ;; same drawable and gcontext? + (or (compare-request (4) + (data 0) + (drawable drawable) + (gcontext gcontext)) + (progn ;; If failed, reset buffer pointers + (set-buffer-offset current-boffset) + nil)))) + ;; Append request + (progn + ;; Set new request length + (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) + -2))) + (set-buffer-offset current-boffset) + (put-items (0) ; Insert new point + (int16 x y)) + (setf (display-boffset display) (index+ buffer-boffset 4))) + ;; New Request + (progn + (put-items (4) + (code +x-polypoint+) + (data 0) ;; Relative-p false + (length 4) + (drawable drawable) + (gcontext gcontext) + (int16 x y)) + (buffer-new-request-number display) + (setf (buffer-last-request display) buffer-boffset) + (setf (display-boffset display) (index+ buffer-boffset 16))))))) (display-invoke-after-function display))) (defun draw-points (drawable gcontext points &optional relative-p) (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p)) + (type gcontext gcontext) + (type sequence points) ;(repeat-seq (integer x) (integer y)) + (type generalized-boolean relative-p)) (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) @@ -87,9 +87,9 @@ (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x1 y1 x2 y2) - (type generalized-boolean relative-p)) + (type gcontext gcontext) + (type int16 x1 y1 x2 y2) + (type generalized-boolean relative-p)) (let ((display (drawable-display drawable))) (declare (type display display)) (when relative-p @@ -98,50 +98,50 @@ (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x1 y1 x2 y2)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code +x-polysegment+) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x1 y1 x2 y2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) + (let* ((last-request-byte (display-last-request display)) + (current-boffset buffer-boffset)) + ;; To append or not append, that is the question + (if (and (not *inhibit-appending*) + last-request-byte + ;; Same request? + (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) + (progn ;; Set buffer pointers to last request + (set-buffer-offset last-request-byte) + ;; same drawable and gcontext? + (or (compare-request (4) + (drawable drawable) + (gcontext gcontext)) + (progn ;; If failed, reset buffer pointers + (set-buffer-offset current-boffset) + nil)))) + ;; Append request + (progn + ;; Set new request length + (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) + -2))) + (set-buffer-offset current-boffset) + (put-items (0) ; Insert new point + (int16 x1 y1 x2 y2)) + (setf (display-boffset display) (index+ buffer-boffset 8))) + ;; New Request + (progn + (put-items (4) + (code +x-polysegment+) + (length 5) + (drawable drawable) + (gcontext gcontext) + (int16 x1 y1 x2 y2)) + (buffer-new-request-number display) + (setf (buffer-last-request display) buffer-boffset) + (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p fill-p) - (type (member :complex :non-convex :convex) shape)) + (type gcontext gcontext) + (type sequence points) ;(repeat-seq (integer x) (integer y)) + (type generalized-boolean relative-p fill-p) + (type (member :complex :non-convex :convex) shape)) (if fill-p (fill-polygon drawable gcontext points relative-p shape) (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) @@ -154,10 +154,10 @@ (defun fill-polygon (drawable gcontext points relative-p shape) ;; This is clever about appending to previous requests. Should it be? (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence points) ;(repeat-seq (integer x) (integer y)) - (type generalized-boolean relative-p) - (type (member :complex :non-convex :convex) shape)) + (type gcontext gcontext) + (type sequence points) ;(repeat-seq (integer x) (integer y)) + (type generalized-boolean relative-p) + (type (member :complex :non-convex :convex) shape)) (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) @@ -167,9 +167,9 @@ (defun draw-segments (drawable gcontext segments) (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) - (type sequence segments)) + (type gcontext gcontext) + ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) + (type sequence segments)) (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) @@ -178,66 +178,66 @@ (defun draw-rectangle (drawable gcontext x y width height &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + (type int16 x y) + (type card16 width height) + (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) + (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) (declare (type display display) - (type card16 request)) + (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height)) - (setf (display-boffset display) (index+ buffer-boffset 8))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 5) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 20))))))) + (let* ((last-request-byte (display-last-request display)) + (current-boffset buffer-boffset)) + ;; To append or not append, that is the question + (if (and (not *inhibit-appending*) + last-request-byte + ;; Same request? + (= (aref-card8 buffer-bbuf last-request-byte) request) + (progn ;; Set buffer pointers to last request + (set-buffer-offset last-request-byte) + ;; same drawable and gcontext? + (or (compare-request (4) + (drawable drawable) + (gcontext gcontext)) + (progn ;; If failed, reset buffer pointers + (set-buffer-offset current-boffset) + nil)))) + ;; Append request + (progn + ;; Set new request length + (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) + -2))) + (set-buffer-offset current-boffset) + (put-items (0) ; Insert new point + (int16 x y) + (card16 width height)) + (setf (display-boffset display) (index+ buffer-boffset 8))) + ;; New Request + (progn + (put-items (4) + (code request) + (length 5) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (card16 width height)) + (buffer-new-request-number display) + (setf (buffer-last-request display) buffer-boffset) + (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-rectangles (drawable gcontext rectangles &optional fill-p) (declare (type drawable drawable) - (type gcontext gcontext) - ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) - (type sequence rectangles) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) + (type sequence rectangles) + (type generalized-boolean fill-p)) (with-buffer-request ((drawable-display drawable) - (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) - :gc-force gcontext) + (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) + :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) rectangles))) @@ -245,128 +245,128 @@ (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type card16 width height) - (type angle angle1 angle2) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + (type int16 x y) + (type card16 width height) + (type angle angle1 angle2) + (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (declare (type display display) - (type card16 request)) + (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) - (let* ((last-request-byte (display-last-request display)) - (current-boffset buffer-boffset)) - ;; To append or not append, that is the question - (if (and (not *inhibit-appending*) - last-request-byte - ;; Same request? - (= (aref-card8 buffer-bbuf last-request-byte) request) - (progn ;; Set buffer pointers to last request - (set-buffer-offset last-request-byte) - ;; same drawable and gcontext? - (or (compare-request (4) - (drawable drawable) - (gcontext gcontext)) - (progn ;; If failed, reset buffer pointers - (set-buffer-offset current-boffset) - nil)))) - ;; Append request - (progn - ;; Set new request length - (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) - -2))) - (set-buffer-offset current-boffset) - (put-items (0) ; Insert new point - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (setf (display-boffset display) (index+ buffer-boffset 12))) - ;; New Request - (progn - (put-items (4) - (code request) - (length 6) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card16 width height) - (angle angle1 angle2)) - (buffer-new-request-number display) - (setf (buffer-last-request display) buffer-boffset) - (setf (display-boffset display) (index+ buffer-boffset 24))))))) + (let* ((last-request-byte (display-last-request display)) + (current-boffset buffer-boffset)) + ;; To append or not append, that is the question + (if (and (not *inhibit-appending*) + last-request-byte + ;; Same request? + (= (aref-card8 buffer-bbuf last-request-byte) request) + (progn ;; Set buffer pointers to last request + (set-buffer-offset last-request-byte) + ;; same drawable and gcontext? + (or (compare-request (4) + (drawable drawable) + (gcontext gcontext)) + (progn ;; If failed, reset buffer pointers + (set-buffer-offset current-boffset) + nil)))) + ;; Append request + (progn + ;; Set new request length + (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) + -2))) + (set-buffer-offset current-boffset) + (put-items (0) ; Insert new point + (int16 x y) + (card16 width height) + (angle angle1 angle2)) + (setf (display-boffset display) (index+ buffer-boffset 12))) + ;; New Request + (progn + (put-items (4) + (code request) + (length 6) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (card16 width height) + (angle angle1 angle2)) + (buffer-new-request-number display) + (setf (buffer-last-request display) buffer-boffset) + (setf (display-boffset display) (index+ buffer-boffset 24))))))) (display-invoke-after-function display))) (defun draw-arcs-list (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) - (type gcontext gcontext) - (type list arcs) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + (type list arcs) + (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) + (limit (index- (buffer-size display) 12)) + (length (length arcs)) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((arc arcs)) - ((endp arc) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (pop arc)) - (int16-put 2 (pop arc)) - (card16-put 4 (pop arc)) - (card16-put 6 (pop arc)) - (angle-put 8 (pop arc)) - (angle-put 10 (pop arc)) - (set-buffer-offset (index+ buffer-boffset 12))))))) + (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) + (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data + (do ((arc arcs)) + ((endp arc) + (setf (buffer-boffset display) buffer-boffset)) + ;; Make sure there's room + (when (index>= buffer-boffset limit) + (setf (buffer-boffset display) buffer-boffset) + (buffer-flush display) + (set-buffer-offset (buffer-boffset display))) + (int16-put 0 (pop arc)) + (int16-put 2 (pop arc)) + (card16-put 4 (pop arc)) + (card16-put 6 (pop arc)) + (angle-put 8 (pop arc)) + (angle-put 10 (pop arc)) + (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) - (type gcontext gcontext) - (type vector arcs) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + (type vector arcs) + (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) - (limit (index- (buffer-size display) 12)) - (length (length arcs)) - (request (if fill-p +x-polyfillarc+ +x-polyarc+))) + (limit (index- (buffer-size display) 12)) + (length (length arcs)) + (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn - (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) - (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data - (do ((n 0 (index+ n 6)) - (length (length arcs))) - ((index>= n length) - (setf (buffer-boffset display) buffer-boffset)) - ;; Make sure there's room - (when (index>= buffer-boffset limit) - (setf (buffer-boffset display) buffer-boffset) - (buffer-flush display) - (set-buffer-offset (buffer-boffset display))) - (int16-put 0 (aref arcs (index+ n 0))) - (int16-put 2 (aref arcs (index+ n 1))) - (card16-put 4 (aref arcs (index+ n 2))) - (card16-put 6 (aref arcs (index+ n 3))) - (angle-put 8 (aref arcs (index+ n 4))) - (angle-put 10 (aref arcs (index+ n 5))) - (set-buffer-offset (index+ buffer-boffset 12))))))) + (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) + (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data + (do ((n 0 (index+ n 6)) + (length (length arcs))) + ((index>= n length) + (setf (buffer-boffset display) buffer-boffset)) + ;; Make sure there's room + (when (index>= buffer-boffset limit) + (setf (buffer-boffset display) buffer-boffset) + (buffer-flush display) + (set-buffer-offset (buffer-boffset display))) + (int16-put 0 (aref arcs (index+ n 0))) + (int16-put 2 (aref arcs (index+ n 1))) + (card16-put 4 (aref arcs (index+ n 2))) + (card16-put 6 (aref arcs (index+ n 3))) + (angle-put 8 (aref arcs (index+ n 4))) + (angle-put 10 (aref arcs (index+ n 5))) + (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence arcs) - (type generalized-boolean fill-p)) + (type gcontext gcontext) + (type sequence arcs) + (type generalized-boolean fill-p)) (etypecase arcs (list (draw-arcs-list drawable gcontext arcs fill-p)) (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) @@ -377,26 +377,26 @@ ;; for reading and writing the data. (defun put-raw-image (drawable gcontext data &key - (start 0) - (depth (required-arg depth)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (left-pad 0) - (format (required-arg format))) + (start 0) + (depth (required-arg depth)) + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + (left-pad 0) + (format (required-arg format))) ;; Data must be a sequence of 8-bit quantities, already in the appropriate format ;; for transmission; the caller is responsible for all byte and bit swapping and ;; compaction. Start is the starting index in data; the end is computed from the ;; other arguments. (declare (type drawable drawable) - (type gcontext gcontext) - (type sequence data) ; Sequence of integers - (type array-index start) - (type card8 depth left-pad) ;; required - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (member :bitmap :xy-pixmap :z-pixmap) format)) + (type gcontext gcontext) + (type sequence data) ; Sequence of integers + (type array-index start) + (type card8 depth left-pad) ;; required + (type int16 x y) ;; required + (type card16 width height) ;; required + (type (member :bitmap :xy-pixmap :z-pixmap) format)) (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) format) (drawable drawable) @@ -408,40 +408,40 @@ ((sequence :format card8 :start start) data))) (defun get-raw-image (drawable &key - data - (start 0) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (plane-mask #xffffffff) - (format (required-arg format)) - (result-type '(vector card8))) + data + (start 0) + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + (plane-mask #xffffffff) + (format (required-arg format)) + (result-type '(vector card8))) ;; If data is given, it is modified in place (and returned), otherwise a new sequence ;; is created and returned, with a size computed from the other arguments and the ;; returned depth. The sequence is filled with 8-bit quantities, in transmission ;; format; the caller is responsible for any byte and bit swapping and compaction ;; required for further local use. (declare (type drawable drawable) - (type (or null sequence) data) ;; sequence of integers - (type int16 x y) ;; required - (type card16 width height) ;; required - (type array-index start) - (type pixel plane-mask) - (type (member :xy-pixmap :z-pixmap) format)) + (type (or null sequence) data) ;; sequence of integers + (type int16 x y) ;; required + (type card16 width height) ;; required + (type array-index start) + (type pixel plane-mask) + (type (member :xy-pixmap :z-pixmap) format)) (declare (clx-values (clx-sequence integer) depth visual-info)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) + (((data (member error :xy-pixmap :z-pixmap)) format) + (drawable drawable) + (int16 x y) + (card16 width height) + (card32 plane-mask)) (let ((depth (card8-get 1)) - (length (* 4 (card32-get 4))) - (visual (resource-id-get 8))) - (values (sequence-get :result-type result-type :format card8 - :length length :start start :data data - :index +replysize+) - depth - (visual-info display visual)))))) + (length (* 4 (card32-get 4))) + (visual (resource-id-get 8))) + (values (sequence-get :result-type result-type :format card8 + :length length :start start :data data + :index +replysize+) + depth + (visual-info display visual)))))) diff --git a/src/clx/image.lisp b/src/clx/image.lisp index 158359692..a52caa898 100644 --- a/src/clx/image.lisp +++ b/src/clx/image.lisp @@ -3,9 +3,9 @@ ;;; CLX Image functions ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -25,10 +25,10 @@ `(let ((.reply-buffer. (allocate-reply-buffer ,size))) (declare (type reply-buffer .reply-buffer.)) (unwind-protect - (let ((,buffer (reply-ibuf8 .reply-buffer.))) - (declare (type buffer-bytes ,buffer)) - (with-vector (,buffer buffer-bytes) - ,@body)) + (let ((,buffer (reply-ibuf8 .reply-buffer.))) + (declare (type buffer-bytes ,buffer)) + (with-vector (,buffer buffer-bytes) + ,@body)) (deallocate-reply-buffer .reply-buffer.)))) (def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) @@ -48,7 +48,7 @@ (defun print-image (image stream depth) (declare (type image image) - (ignore depth)) + (ignore depth)) (print-unreadable-object (image stream :type t) (when (image-name image) (write-string (string (image-name image)) stream) @@ -65,52 +65,52 @@ '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) (def-clx-class (image-x (:include image) (:copier nil) - (:print-function print-image)) + (:print-function print-image)) ;; Use this format for shoveling image data ;; Private structure. Accessors for these NOT exported. (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) (bytes-per-line 0 :type card16) (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) - (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order - (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order - (data +empty-data-x+ :type (array card8 (*))) ; row-major - (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit - (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad - (left-pad 0 :type card8)) ; Left pad + (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order + (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order + (data +empty-data-x+ :type (array card8 (*))) ; row-major + (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit + (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad + (left-pad 0 :type card8)) ; Left pad (def-clx-class (image-xy (:include image) (:copier nil) - (:print-function print-image)) + (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bitmap-list nil :type list)) ;; list of bitmaps (def-clx-class (image-z (:include image) (:copier nil) - (:print-function print-image)) + (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) (pixarray +empty-data-z+ :type pixarray)) (defun create-image (&key width height depth - (data (required-arg data)) - plist name x-hot y-hot - red-mask blue-mask green-mask - bits-per-pixel format bytes-per-line - (byte-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - (bit-lsb-first-p - #+clx-little-endian t - #-clx-little-endian nil) - unit pad left-pad) + (data (required-arg data)) + plist name x-hot y-hot + red-mask blue-mask green-mask + bits-per-pixel format bytes-per-line + (byte-lsb-first-p + #+clx-little-endian t + #-clx-little-endian nil) + (bit-lsb-first-p + #+clx-little-endian t + #-clx-little-endian nil) + unit pad left-pad) ;; Returns an image-x image-xy or image-z structure, depending on the ;; type of the :DATA parameter. (declare - (type (or null card16) width height) ; Required - (type (or null card8) depth) ; Defualts to 1 - (type (or buffer-bytes ; Returns image-x - list ; Returns image-xy - pixarray) data) ; Returns image-z + (type (or null card16) width height) ; Required + (type (or null card8) depth) ; Defualts to 1 + (type (or buffer-bytes ; Returns image-x + list ; Returns image-xy + pixarray) data) ; Returns image-z (type list plist) (type (or null stringable) name) (type (or null card16) x-hot y-hot) @@ -119,85 +119,85 @@ ;; The following parameters are ignored for image-xy and image-z: (type (or null (member :bitmap :xy-pixmap :z-pixmap)) - format) ; defaults to :z-pixmap + format) ; defaults to :z-pixmap (type (or null card16) bytes-per-line) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (type (or null (member 8 16 32)) unit pad) (type (or null card8) left-pad)) (declare (clx-values image)) (let ((image - (etypecase data - (buffer-bytes ; image-x - (let ((data data)) - (declare (type buffer-bytes data)) - (unless depth (setq depth (or bits-per-pixel 1))) - (unless format - (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) - (unless bits-per-pixel - (setq bits-per-pixel - (cond ((eq format :xy-pixmap) 1) - ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1)))) - (unless width (required-arg width)) - (unless height (required-arg height)) - (unless bytes-per-line - (let* ((pad (or pad 8)) - (bits-per-line (index* width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad))) - (declare (type array-index pad bits-per-line - padded-bits-per-line)) - (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) - (unless unit (setq unit +image-unit+)) - (unless pad - (setq pad - (dolist (pad '(32 16 8)) - (when (and (index<= pad +image-pad+) - (zerop - (index-mod - (index* bytes-per-line 8) pad))) - (return pad))))) - (unless left-pad (setq left-pad 0)) - (make-image-x - :width width :height height :depth depth :plist plist - :format format :data data - :bits-per-pixel bits-per-pixel - :bytes-per-line bytes-per-line - :byte-lsb-first-p byte-lsb-first-p - :bit-lsb-first-p bit-lsb-first-p - :unit unit :pad pad :left-pad left-pad))) - (list ; image-xy - (let ((data data)) - (declare (type list data)) - (unless depth (setq depth (length data))) - (when data - (unless width (setq width (array-dimension (car data) 1))) - (unless height (setq height (array-dimension (car data) 0)))) - (make-image-xy - :width width :height height :plist plist :depth depth - :bitmap-list data))) - (pixarray ; image-z - (let ((data data)) - (declare (type pixarray data)) - (unless width (setq width (array-dimension data 1))) - (unless height (setq height (array-dimension data 0))) - (unless bits-per-pixel - (setq bits-per-pixel - (etypecase data - (pixarray-32 32) - (pixarray-24 24) - (pixarray-16 16) - (pixarray-8 8) - (pixarray-4 4) - (pixarray-1 1))))) - (unless depth (setq depth bits-per-pixel)) - (make-image-z - :width width :height height :depth depth :plist plist - :bits-per-pixel bits-per-pixel :pixarray data))))) + (etypecase data + (buffer-bytes ; image-x + (let ((data data)) + (declare (type buffer-bytes data)) + (unless depth (setq depth (or bits-per-pixel 1))) + (unless format + (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) + (unless bits-per-pixel + (setq bits-per-pixel + (cond ((eq format :xy-pixmap) 1) + ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1)))) + (unless width (required-arg width)) + (unless height (required-arg height)) + (unless bytes-per-line + (let* ((pad (or pad 8)) + (bits-per-line (index* width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad))) + (declare (type array-index pad bits-per-line + padded-bits-per-line)) + (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) + (unless unit (setq unit +image-unit+)) + (unless pad + (setq pad + (dolist (pad '(32 16 8)) + (when (and (index<= pad +image-pad+) + (zerop + (index-mod + (index* bytes-per-line 8) pad))) + (return pad))))) + (unless left-pad (setq left-pad 0)) + (make-image-x + :width width :height height :depth depth :plist plist + :format format :data data + :bits-per-pixel bits-per-pixel + :bytes-per-line bytes-per-line + :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p + :unit unit :pad pad :left-pad left-pad))) + (list ; image-xy + (let ((data data)) + (declare (type list data)) + (unless depth (setq depth (length data))) + (when data + (unless width (setq width (array-dimension (car data) 1))) + (unless height (setq height (array-dimension (car data) 0)))) + (make-image-xy + :width width :height height :plist plist :depth depth + :bitmap-list data))) + (pixarray ; image-z + (let ((data data)) + (declare (type pixarray data)) + (unless width (setq width (array-dimension data 1))) + (unless height (setq height (array-dimension data 0))) + (unless bits-per-pixel + (setq bits-per-pixel + (etypecase data + (pixarray-32 32) + (pixarray-24 24) + (pixarray-16 16) + (pixarray-8 8) + (pixarray-4 4) + (pixarray-1 1))))) + (unless depth (setq depth bits-per-pixel)) + (make-image-z + :width width :height height :depth depth :plist plist + :bits-per-pixel bits-per-pixel :pixarray data))))) (declare (type image image)) (when name (setf (image-name image) name)) (when x-hot (setf (image-x-hot image) x-hot)) @@ -213,446 +213,446 @@ (defun image-noswap (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p) + (ignore lsb-first-p)) #.(declare-buffun) (if (index= srcinc destinc) (buffer-replace - dest src destoff - (index+ destoff (index* srcinc (index1- height)) srclen) - srcoff) + dest src destoff + (index+ destoff (index* srcinc (index1- height)) srclen) + srcoff) (do* ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc)) - (destend (index+ deststart srclen) (index+ deststart srclen))) - ((index-zerop h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc)) + (destend (index+ deststart srclen) (index+ deststart srclen))) + ((index-zerop h)) (declare (type array-index srcstart deststart destend) - (type card16 h)) + (type card16 h)) (buffer-replace dest src deststart destend srcstart)))) (defun image-swap-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src srcidx)))))))) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src srcidx)))))))) (defun image-swap-three-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 3) 3)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 3) - (when (index= (index- srclen length) 2) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 1))))) - (if lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2)))))) - (do ((i length (index- i 3)) - (srcidx srcstart (index+ srcidx 3)) - (destidx deststart (index+ destidx 3))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx)))))))) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 3) + (when (index= (index- srclen length) 2) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 1))))) + (if lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2)))))) + (do ((i length (index- i 3)) + (srcidx srcstart (index+ srcidx 3)) + (destidx deststart (index+ destidx 3))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx)))))))) (defun image-swap-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src srcidx)))))))) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src srcidx)))))))) (defun image-swap-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (the card8 (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (the card8 (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (the card8 (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (the card8 (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (the card8 (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (the card8 (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (the card8 (aref src (index1+ srcidx))))))))) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src (index1+ srcidx))))))))) (defun image-swap-nibbles (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p) + (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte (aref src srcidx))) - (declare (type card8 byte)) - (dpb (the card4 (ldb (byte 4 0) byte)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte))))))))))) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte (aref src srcidx))) + (declare (type card8 byte)) + (dpb (the card4 (ldb (byte 4 0) byte)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte))))))))))) (defun image-swap-nibbles-left (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p) + (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index= i 1) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx))) - (declare (type card8 byte1)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - 0))))) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (the card8 - (let ((byte1 (aref src srcidx)) - (byte2 (aref src (index1+ srcidx)))) - (declare (type card8 byte1 byte2)) - (dpb (the card4 (ldb (byte 4 0) byte1)) - (byte 4 4) - (the card4 (ldb (byte 4 4) byte2))))))))))) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index= i 1) + (setf (aref dest destidx) + (the card8 + (let ((byte1 (aref src srcidx))) + (declare (type card8 byte1)) + (dpb (the card4 (ldb (byte 4 0) byte1)) + (byte 4 4) + 0))))) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte1 (aref src srcidx)) + (byte2 (aref src (index1+ srcidx)))) + (declare (type card8 byte1 byte2)) + (dpb (the card4 (ldb (byte 4 0) byte1)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte2))))))))))) (defconstant +image-byte-reverse+ '#.(coerce '#( - 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 - 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 - 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 - 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 - 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 - 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 - 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 - 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 - 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 - 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 - 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 - 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 - 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 - 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 - 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 - 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) + 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 + 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 + 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 + 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 + 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 + 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 + 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 + 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 + 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 + 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 + 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 + 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 + 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 + 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 + 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 + 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) '(vector card8))) (defun image-swap-bits (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p) - (ignore lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p) + (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index srcstart deststart) - (type card16 h)) - (do ((i srclen (index1- i)) - (srcidx srcstart (index1+ srcidx)) - (destidx deststart (index1+ destidx))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) (br (aref src srcidx))))))))))) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 2) 2)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 2) - (if lsb-first-p - (setf (aref dest (index1+ (index+ deststart length))) - (br (aref src (index+ srcstart length)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index1+ (index+ srcstart length))))))) - (do ((i length (index- i 2)) - (srcidx srcstart (index+ srcidx 2)) - (destidx deststart (index+ destidx 2))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index1+ destidx)) - (br (aref src srcidx))))))))))) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 2) 2)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (br (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (br (aref src srcidx))))))))))) (defun image-swap-bits-and-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src (index1+ srcidx)))) - (setf (aref dest (index+ destidx 3)) - (br (aref src srcidx))))))))))) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (br (aref src srcidx))))))))))) (defun image-swap-bits-and-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) - (type array-index srcoff destoff srclen srcinc destinc) - (type card16 height) - (type generalized-boolean lsb-first-p)) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) - (with-vector (byte-reverse (simple-array card8 (256))) - (macrolet ((br (byte) - `(the card8 (aref byte-reverse (the card8 ,byte))))) - (do ((length (index* (index-ceiling srclen 4) 4)) - (h height (index1- h)) - (srcstart srcoff (index+ srcstart srcinc)) - (deststart destoff (index+ deststart destinc))) - ((index-zerop h)) - (declare (type array-index length srcstart deststart) - (type card16 h)) - (when (and (index= h 1) (not (index= srclen length))) - (index-decf length 4) - (unless lsb-first-p - (setf (aref dest (index+ deststart length 1)) - (br (aref src (index+ srcstart length 3))))) - (when (if lsb-first-p - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length)) - (br (aref src (index+ srcstart length 2))))) - (when (if (null lsb-first-p) - (index= (index- srclen length) 3) - (not (index-zerop (index-logand srclen 2)))) - (setf (aref dest (index+ deststart length 3)) - (br (aref src (index+ srcstart length 1))))) - (when lsb-first-p - (setf (aref dest (index+ deststart length 2)) - (br (aref src (index+ srcstart length)))))) - (do ((i length (index- i 4)) - (srcidx srcstart (index+ srcidx 4)) - (destidx deststart (index+ destidx 4))) - ((index-zerop i)) - (declare (type array-index i srcidx destidx)) - (setf (aref dest destidx) - (br (aref src (index+ srcidx 2)))) - (setf (aref dest (index1+ destidx)) - (br (aref src (index+ srcidx 3)))) - (setf (aref dest (index+ destidx 2)) - (br (aref src srcidx))) - (setf (aref dest (index+ destidx 3)) - (br (aref src (index1+ srcidx)))))))))))) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (br (aref src (index1+ srcidx)))))))))))) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to @@ -661,29 +661,29 @@ ;;; for the least significant bit. ;;; ;;; legend: -;;; 1 scanline-unit = 8 -;;; 2 scanline-unit = 16 -;;; 4 scanline-unit = 32 -;;; M byte-order = MostSignificant -;;; L byte-order = LeastSignificant -;;; m bit-order = MostSignificant -;;; l bit-order = LeastSignificant +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant ;;; ;;; -;;; format ordering +;;; format ordering ;;; -;;; 1Mm 00-07 08-15 16-23 24-31 -;;; 2Mm 00-07 08-15 16-23 24-31 -;;; 4Mm 00-07 08-15 16-23 24-31 -;;; 1Ml 07-00 15-08 23-16 31-24 -;;; 2Ml 15-08 07-00 31-24 23-16 -;;; 4Ml 31-24 23-16 15-08 07-00 -;;; 1Lm 00-07 08-15 16-23 24-31 -;;; 2Lm 08-15 00-07 24-31 16-23 -;;; 4Lm 24-31 16-23 08-15 00-07 -;;; 1Ll 07-00 15-08 23-16 31-24 -;;; 2Ll 07-00 15-08 23-16 31-24 -;;; 4Ll 07-00 15-08 23-16 31-24 +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 ;;; ;;; ;;; The following table gives the required conversion between any two @@ -691,39 +691,39 @@ ;;; you should believe the other. ;;; ;;; legend: -;;; n no changes -;;; s reverse 8-bit units within 16-bit units -;;; l reverse 8-bit units within 32-bit units -;;; w reverse 16-bit units within 32-bit units -;;; r reverse bits within 8-bit units -;;; sr s+R -;;; lr l+R -;;; wr w+R +;;; n no changes +;;; s reverse 8-bit units within 16-bit units +;;; l reverse 8-bit units within 32-bit units +;;; w reverse 16-bit units within 32-bit units +;;; r reverse bits within 8-bit units +;;; sr s+R +;;; lr l+R +;;; wr w+R (defconstant +image-swap-function+ '#.(make-array '(12 12) :initial-contents (let ((n 'image-noswap) - (s 'image-swap-two-bytes) - (l 'image-swap-four-bytes) - (w 'image-swap-words) - (r 'image-swap-bits) - (sr 'image-swap-bits-and-two-bytes) - (lr 'image-swap-bits-and-four-bytes) - (wr 'image-swap-bits-and-words)) + (s 'image-swap-two-bytes) + (l 'image-swap-four-bytes) + (w 'image-swap-words) + (r 'image-swap-bits) + (sr 'image-swap-bits-and-two-bytes) + (lr 'image-swap-bits-and-four-bytes) + (wr 'image-swap-bits-and-words)) (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# - (list #| 1Mm |# n n n r sr lr n s l r r r ) - (list #| 2Mm |# n n n r sr lr n s l r r r ) - (list #| 4Mm |# n n n r sr lr n s l r r r ) - (list #| 1Ml |# r r r n s l r sr lr n n n ) - (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) - (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) - (list #| 1Lm |# n n n r sr lr n s l r r r ) - (list #| 2Lm |# s s s sr r wr s n w sr sr sr) - (list #| 4Lm |# l l l lr wr r l w n lr lr lr) - (list #| 1Ll |# r r r n s l r sr lr n n n ) - (list #| 2Ll |# r r r n s l r sr lr n n n ) - (list #| 4Ll |# r r r n s l r sr lr n n n ))))) + (list #| 1Mm |# n n n r sr lr n s l r r r ) + (list #| 2Mm |# n n n r sr lr n s l r r r ) + (list #| 4Mm |# n n n r sr lr n s l r r r ) + (list #| 1Ml |# r r r n s l r sr lr n n n ) + (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) + (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) + (list #| 1Lm |# n n n r sr lr n s l r r r ) + (list #| 2Lm |# s s s sr r wr s n w sr sr sr) + (list #| 4Lm |# l l l lr wr r l w n lr lr lr) + (list #| 1Ll |# r r r n s l r sr lr n n n ) + (list #| 2Ll |# r r r n s l r sr lr n n n ) + (list #| 4Ll |# r r r n s l r sr lr n n n ))))) ;;; Of course, the table above is a lie. We also need to factor in the ;;; order of the source data to cope with swapping half of a unit at the @@ -736,435 +736,435 @@ '#.(make-array 12 :initial-contents (list t #| 1mm |# - t #| 2mm |# - t #| 4mm |# - t #| 1ml |# - nil #| 2ml |# - nil #| 4ml |# - t #| 1lm |# - nil #| 2lm |# - nil #| 4lm |# - t #| 1ll |# - t #| 2ll |# - t #| 4ll |# - ))) + t #| 2mm |# + t #| 4mm |# + t #| 1ml |# + nil #| 2ml |# + nil #| 4ml |# + t #| 1lm |# + nil #| 2lm |# + nil #| 4lm |# + t #| 1ll |# + t #| 2ll |# + t #| 4ll |# + ))) (defun image-swap-function (bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p) - (clx-values function lsb-first-p)) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p) + (clx-values function lsb-first-p)) (cond ((index= bits-per-pixel 1) - (let ((from-index - (index+ - (ecase from-bitmap-unit (32 2) (16 1) (8 0)) - (if from-bit-lsb-first-p 3 0) - (if from-byte-lsb-first-p 6 0)))) - (values - (aref +image-swap-function+ from-index - (index+ - (ecase to-bitmap-unit (32 2) (16 1) (8 0)) - (if to-bit-lsb-first-p 3 0) - (if to-byte-lsb-first-p 6 0))) - (aref +image-swap-lsb-first-p+ from-index)))) - (t - (values - (if (if (index= bits-per-pixel 4) - (eq from-bit-lsb-first-p to-bit-lsb-first-p) - (eq from-byte-lsb-first-p to-byte-lsb-first-p)) - 'image-noswap - (ecase bits-per-pixel - (4 'image-swap-nibbles) - (8 'image-noswap) - (16 'image-swap-two-bytes) - (24 'image-swap-three-bytes) - (32 'image-swap-four-bytes))) - from-byte-lsb-first-p)))) + (let ((from-index + (index+ + (ecase from-bitmap-unit (32 2) (16 1) (8 0)) + (if from-bit-lsb-first-p 3 0) + (if from-byte-lsb-first-p 6 0)))) + (values + (aref +image-swap-function+ from-index + (index+ + (ecase to-bitmap-unit (32 2) (16 1) (8 0)) + (if to-bit-lsb-first-p 3 0) + (if to-byte-lsb-first-p 6 0))) + (aref +image-swap-lsb-first-p+ from-index)))) + (t + (values + (if (if (index= bits-per-pixel 4) + (eq from-bit-lsb-first-p to-bit-lsb-first-p) + (eq from-byte-lsb-first-p to-byte-lsb-first-p)) + 'image-noswap + (ecase bits-per-pixel + (4 'image-swap-nibbles) + (8 'image-noswap) + (16 'image-swap-two-bytes) + (24 'image-swap-three-bytes) + (32 'image-swap-four-bytes))) + from-byte-lsb-first-p)))) ;;;----------------------------------------------------------------------------- ;;; GET-IMAGE (defun read-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 8)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-bits (the array-index - (mod (the (integer #x-FFFF 0) (- x)) - 8))) - (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (- width left-bits right-bits)) - (middle-bytes (floor middle-bits 8))) - ((index>= y height)) + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (the array-index + (mod (the (integer #x-FFFF 0) (- x)) + 8))) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (- width left-bits right-bits)) + (middle-bytes (floor middle-bits 8))) + ((index>= y height)) (declare (type array-index start y left-bits right-bits)) (declare (fixnum middle-bits middle-bytes)) (cond ((< middle-bits 0) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (when (index> right-bits 6) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte))) - (when (and (index> left-bits 1) - (index> right-bits 5)) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte))) - (when (and (index> left-bits 2) - (index> right-bits 4)) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte))) - (when (and (index> left-bits 3) - (index> right-bits 3)) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte))) - (when (and (index> left-bits 4) - (index> right-bits 2)) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte))) - (when (and (index> left-bits 5) - (index> right-bits 1)) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte))) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte))))) - (t - (unless (index-zerop left-bits) - (let ((byte (aref buffer-bbuf (index1- start))) - (x left-bits)) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index- x 1)) - (read-image-load-byte 1 7 byte)) - (when (index> left-bits 1) - (setf (aref array y (index- x 2)) - (read-image-load-byte 1 6 byte)) - (when (index> left-bits 2) - (setf (aref array y (index- x 3)) - (read-image-load-byte 1 5 byte)) - (when (index> left-bits 3) - (setf (aref array y (index- x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> left-bits 4) - (setf (aref array y (index- x 5)) - (read-image-load-byte 1 3 byte)) - (when (index> left-bits 5) - (setf (aref array y (index- x 6)) - (read-image-load-byte 1 2 byte)) - (when (index> left-bits 6) - (setf (aref array y (index- x 7)) - (read-image-load-byte 1 1 byte)) - )))))))) - (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-bits (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((byte (aref buffer-bbuf end)) - (x (index+ left-bits middle-bits))) - (declare (type card8 byte) - (type array-index x)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (when (index> right-bits 1) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (when (index> right-bits 2) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (when (index> right-bits 3) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (when (index> right-bits 4) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (when (index> right-bits 5) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (when (index> right-bits 6) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - ))))))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 1 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 1 1 byte)) - (setf (aref array y (index+ x 2)) - (read-image-load-byte 1 2 byte)) - (setf (aref array y (index+ x 3)) - (read-image-load-byte 1 3 byte)) - (setf (aref array y (index+ x 4)) - (read-image-load-byte 1 4 byte)) - (setf (aref array y (index+ x 5)) - (read-image-load-byte 1 5 byte)) - (setf (aref array y (index+ x 6)) - (read-image-load-byte 1 6 byte)) - (setf (aref array y (index+ x 7)) - (read-image-load-byte 1 7 byte)))) - ))))) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x left-bits (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (index+ left-bits middle-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref array y (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) (defun read-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index-ceiling x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y)) - (left-nibbles (mod (the fixnum (- x)) 2)) - (right-nibbles (index-mod (index- width left-nibbles) 2)) - (middle-nibbles (index- width left-nibbles right-nibbles)) - (middle-bytes (index-floor middle-nibbles 2))) - ((index>= y height)) + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (mod (the fixnum (- x)) 2)) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) (declare (type array-index start y - left-nibbles right-nibbles middle-nibbles middle-bytes)) + left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) - (setf (aref array y 0) - (read-image-load-byte - 4 4 (aref buffer-bbuf (index1- start))))) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (x left-nibbles (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref array y (index+ left-nibbles middle-nibbles)) - (read-image-load-byte 4 0 (aref buffer-bbuf end))))) - (declare (type array-index end i x)) - (let ((byte (aref buffer-bbuf i))) - (declare (type card8 byte)) - (setf (aref array y (index+ x 0)) - (read-image-load-byte 4 0 byte)) - (setf (aref array y (index+ x 1)) - (read-image-load-byte 4 4 byte)))) + (i start (index1+ i)) + (x left-nibbles (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 4 4 byte)))) ))) (defun read-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-8 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - x) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) + (index* y padded-bytes-per-line) + x) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start width)) - (i start (index1+ i)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (the card8 (aref buffer-bbuf i))))))) + (i start (index1+ i)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (the card8 (aref buffer-bbuf i))))))) (defun read-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-16 array) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 2)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) + (index* y padded-bytes-per-line) + (index* x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)))))))) + (i start (index+ i 2)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)))))))) (defun read-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 3)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)))))))) + (i start (index+ i 3)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) (defun read-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-32 array) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index - (index* y padded-bytes-per-line) - (index* x 4)) - (index+ start padded-bytes-per-line)) - (y 0 (index1+ y))) - ((index>= y height)) + (index* y padded-bytes-per-line) + (index* x 4)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x 0 (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref array y x) - (read-image-assemble-bytes - (aref buffer-bbuf (index+ i 0)) - (aref buffer-bbuf (index+ i 1)) - (aref buffer-bbuf (index+ i 2)) - (aref buffer-bbuf (index+ i 3)))))))) + (i start (index+ i 4)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)) + (aref buffer-bbuf (index+ i 3)))))))) (defun read-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel read-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) + bits-per-pixel read-pixarray-function + from-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function read-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) + (type array-index boffset padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type function read-pixarray-function) + (type (member 8 16 32) from-unit to-unit) + (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) + bits-per-pixel + from-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (if (eq image-swap-function 'image-noswap) - (funcall - read-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + (funcall + read-pixarray-function + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) bbuf buf - (index+ boffset (index* y padded-bytes-per-line)) 0 - (index-ceiling (index* (index+ x width) bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p) - (funcall - read-pixarray-function - buf 0 pixarray x 0 width height padded-bytes-per-line - bits-per-pixel))))) + (funcall + (symbol-function image-swap-function) bbuf buf + (index+ boffset (index* y padded-bytes-per-line)) 0 + (index-ceiling (index* (index+ x width) bits-per-pixel) 8) + padded-bytes-per-line padded-bytes-per-line height + image-swap-lsb-first-p) + (funcall + read-pixarray-function + buf 0 pixarray x 0 width height padded-bytes-per-line + bits-per-pixel))))) (defun read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type array-index boffset padded-bytes-per-line) - (type pixarray pixarray) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type array-index boffset padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-read-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel - ( 1 #'read-pixarray-1 ) - ( 4 #'read-pixarray-4 ) - ( 8 #'read-pixarray-8 ) - (16 #'read-pixarray-16) - (24 #'read-pixarray-24) - (32 #'read-pixarray-32)) + ( 1 #'read-pixarray-1 ) + ( 4 #'read-pixarray-4 ) + ( 8 #'read-pixarray-8 ) + (16 #'read-pixarray-16) + (24 #'read-pixarray-24) + (32 #'read-pixarray-32)) unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) (defun read-xy-format-image-x (buffer-bbuf index length data width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p pad) + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p pad) (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-x)) + (type card16 width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) + (clx-values image-x)) (assert (index<= (index* depth padded-bytes-per-plane) length)) (let* ((bytes-per-line (index-ceiling width 8)) - (data-length (index* padded-bytes-per-plane depth))) + (data-length (index* padded-bytes-per-plane depth))) (declare (type array-index bytes-per-line data-length)) (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) (do ((plane 0 (index1+ plane))) - ((index>= plane depth)) + ((index>= plane depth)) (declare (type image-depth plane)) (image-noswap - buffer-bbuf data - (index+ index (index* plane padded-bytes-per-plane)) - (index* plane padded-bytes-per-plane) - bytes-per-line padded-bytes-per-line padded-bytes-per-line - height byte-lsb-first-p)) + buffer-bbuf data + (index+ index (index* plane padded-bytes-per-plane)) + (index* plane padded-bytes-per-plane) + bytes-per-line padded-bytes-per-line padded-bytes-per-line + height byte-lsb-first-p)) (create-image :width width :height height :depth depth :data data :bits-per-pixel 1 :format :xy-pixmap @@ -1174,25 +1174,25 @@ (defun read-z-format-image-x (buffer-bbuf index length data width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type card16 width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 8 16 32) unit pad) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (clx-values image-x)) + (type card16 width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (clx-values image-x)) (assert (index<= (index* height padded-bytes-per-line) length)) (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) - (data-length (index* padded-bytes-per-line height))) + (data-length (index* padded-bytes-per-line height))) (declare (type array-index bytes-per-line data-length)) (cond (data - (check-type data buffer-bytes) - (assert (index>= (length data) data-length))) - (t - (setq data (make-array data-length :element-type 'card8)))) + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) (image-noswap buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line padded-bytes-per-line height byte-lsb-first-p) @@ -1204,75 +1204,75 @@ :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun read-image-xy (bbuf index length data x y width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line - padded-bytes-per-plane) - (type image-depth depth) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-xy)) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) + (clx-values image-xy)) (check-type data list) (multiple-value-bind (dimensions element-type) (if data - (values (array-dimensions (first data)) - (array-element-type (first data))) - (values (list height - (index* (index-ceiling width +image-pad+) +image-pad+)) - 'pixarray-1-element-type)) + (values (array-dimensions (first data)) + (array-element-type (first data))) + (values (list height + (index* (index-ceiling width +image-pad+) +image-pad+)) + 'pixarray-1-element-type)) (do* ((arrays data) - (result nil) - (limit (index+ length index)) - (plane 0 (1+ plane)) - (index index (index+ index padded-bytes-per-plane))) - ((or (>= plane depth) - (index> (index+ index padded-bytes-per-plane) limit)) - (setq data (nreverse result) depth (length data))) + (result nil) + (limit (index+ length index)) + (plane 0 (1+ plane)) + (index index (index+ index padded-bytes-per-plane))) + ((or (>= plane depth) + (index> (index+ index padded-bytes-per-plane) limit)) + (setq data (nreverse result) depth (length data))) (declare (type array-index limit index) - (type image-depth plane) - (type list arrays result)) + (type image-depth plane) + (type list arrays result)) (let ((array (or (pop arrays) - (make-array dimensions :element-type element-type)))) - (declare (type pixarray-1 array)) - (push array result) - (read-pixarray - bbuf index array x y width height padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p))) + (make-array dimensions :element-type element-type)))) + (declare (type pixarray-1 array)) + (push array result) + (read-pixarray + bbuf index array x y width height padded-bytes-per-line 1 + unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth depth :data data))) (defun read-image-z (bbuf index length data x y width height depth - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type card16 x y width height) - (type array-index index length padded-bytes-per-line) - (type image-depth depth) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) - (clx-values image-z)) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) + (clx-values image-z)) (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) (let* ((image-bits-per-line (index* width bits-per-pixel)) - (image-pixels-per-line - (index-ceiling - (index* (index-ceiling image-bits-per-line +image-pad+) - +image-pad+) - bits-per-pixel))) + (image-pixels-per-line + (index-ceiling + (index* (index-ceiling image-bits-per-line +image-pad+) + +image-pad+) + bits-per-pixel))) (declare (type array-index image-bits-per-line image-pixels-per-line)) (unless data (setq data - (make-array - (list height image-pixels-per-line) - :element-type (ecase bits-per-pixel - (1 'pixarray-1-element-type) - (4 'pixarray-4-element-type) - (8 'pixarray-8-element-type) - (16 'pixarray-16-element-type) - (24 'pixarray-24-element-type) - (32 'pixarray-32-element-type))))) + (make-array + (list height image-pixels-per-line) + :element-type (ecase bits-per-pixel + (1 'pixarray-1-element-type) + (4 'pixarray-4-element-type) + (8 'pixarray-8-element-type) + (16 'pixarray-16-element-type) + (24 'pixarray-24-element-type) + (32 'pixarray-32-element-type))))) (read-pixarray bbuf index data x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) @@ -1281,691 +1281,691 @@ :bits-per-pixel bits-per-pixel))) (defun get-image (drawable &key - data - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - plane-mask format result-type) + data + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + plane-mask format result-type) (declare (type drawable drawable) - (type (or buffer-bytes list pixarray) data) - (type int16 x y) ;; required - (type card16 width height) ;; required - (type (or null pixel) plane-mask) - (type (or null (member :xy-pixmap :z-pixmap)) format) - (type (or null (member image-xy image-x image-z)) result-type) - (clx-values image visual-info)) + (type (or buffer-bytes list pixarray) data) + (type int16 x y) ;; required + (type card16 width height) ;; required + (type (or null pixel) plane-mask) + (type (or null (member :xy-pixmap :z-pixmap)) format) + (type (or null (member image-xy image-x image-z)) result-type) + (clx-values image visual-info)) (unless result-type (setq result-type (ecase format - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z) - ((nil) 'image-x)))) + (:xy-pixmap 'image-xy) + (:z-pixmap 'image-z) + ((nil) 'image-x)))) (unless format (setq format (case result-type - (image-xy :xy-pixmap) - ((image-z image-x) :z-pixmap)))) + (image-xy :xy-pixmap) + ((image-z image-x) :z-pixmap)))) (unless (ecase result-type - (image-xy (eq format :xy-pixmap)) - (image-z (eq format :z-pixmap)) - (image-x t)) + (image-xy (eq format :xy-pixmap)) + (image-z (eq format :z-pixmap)) + (image-x t)) (error "Result-type ~s is incompatible with format ~s" - result-type format)) + result-type format)) (unless plane-mask (setq plane-mask #xffffffff)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) - (((data (member error :xy-pixmap :z-pixmap)) format) - (drawable drawable) - (int16 x y) - (card16 width height) - (card32 plane-mask)) + (((data (member error :xy-pixmap :z-pixmap)) format) + (drawable drawable) + (int16 x y) + (card16 width height) + (card32 plane-mask)) (let* ((depth (card8-get 1)) - (length (index* 4 (card32-get 4))) - (visual-info (visual-info display (resource-id-get 8))) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (declare (type image-depth depth) - (type array-index length) - (type (or null visual-info) visual-info) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) - (multiple-value-bind (pad bits-per-pixel) - (ecase format - (:xy-pixmap - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type pixmap-format pixmap-format)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane - (index* padded-bytes-per-line height)) - (image - (ecase result-type - (image-x - (ecase format - (:xy-pixmap - (read-xy-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p - pad)) - (:z-pixmap - (read-z-format-image-x - buffer-bbuf +replysize+ length data - width height depth - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - pad bits-per-pixel)))) - (image-xy - (read-image-xy - buffer-bbuf +replysize+ length data - 0 0 width height depth - padded-bytes-per-line padded-bytes-per-plane - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (read-image-z - buffer-bbuf +replysize+ length data - 0 0 width height depth padded-bytes-per-line - bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p))))) - (declare (type image image) - (type array-index bits-per-line - padded-bits-per-line padded-bytes-per-line)) - (when visual-info - (unless (zerop (visual-info-red-mask visual-info)) - (setf (image-red-mask image) - (visual-info-red-mask visual-info))) - (unless (zerop (visual-info-green-mask visual-info)) - (setf (image-green-mask image) - (visual-info-green-mask visual-info))) - (unless (zerop (visual-info-blue-mask visual-info)) - (setf (image-blue-mask image) - (visual-info-blue-mask visual-info)))) - (values image visual-info))))))) + (length (index* 4 (card32-get 4))) + (visual-info (visual-info display (resource-id-get 8))) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (declare (type image-depth depth) + (type array-index length) + (type (or null visual-info) visual-info) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (multiple-value-bind (pad bits-per-pixel) + (ecase format + (:xy-pixmap + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type pixmap-format pixmap-format)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((bits-per-line (index* bits-per-pixel width)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane + (index* padded-bytes-per-line height)) + (image + (ecase result-type + (image-x + (ecase format + (:xy-pixmap + (read-xy-format-image-x + buffer-bbuf +replysize+ length data + width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p + pad)) + (:z-pixmap + (read-z-format-image-x + buffer-bbuf +replysize+ length data + width height depth + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + pad bits-per-pixel)))) + (image-xy + (read-image-xy + buffer-bbuf +replysize+ length data + 0 0 width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (read-image-z + buffer-bbuf +replysize+ length data + 0 0 width height depth padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p))))) + (declare (type image image) + (type array-index bits-per-line + padded-bits-per-line padded-bytes-per-line)) + (when visual-info + (unless (zerop (visual-info-red-mask visual-info)) + (setf (image-red-mask image) + (visual-info-red-mask visual-info))) + (unless (zerop (visual-info-green-mask visual-info)) + (setf (image-green-mask image) + (visual-info-green-mask visual-info))) + (unless (zerop (visual-info-blue-mask visual-info)) + (setf (image-blue-mask image) + (visual-info-blue-mask visual-info)))) + (values image visual-info))))))) ;;;----------------------------------------------------------------------------- ;;; PUT-IMAGE (defun write-pixarray-1 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-1 array) - (type card16 x y width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-bits (index-mod width 8)) - (middle-bits (index- width right-bits)) - (middle-bytes (index-ceiling middle-bits 8)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index h y right-bits middle-bits - middle-bytes start)) + middle-bytes start)) (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 8))) - ((index>= i end) - (unless (index-zerop right-bits) - (let ((x (index+ start-x middle-bits))) - (declare (type array-index x)) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (if (index> right-bits 1) - (aref array y (index+ x 1)) - 0) - (if (index> right-bits 2) - (aref array y (index+ x 2)) - 0) - (if (index> right-bits 3) - (aref array y (index+ x 3)) - 0) - (if (index> right-bits 4) - (aref array y (index+ x 4)) - 0) - (if (index> right-bits 5) - (aref array y (index+ x 5)) - 0) - (if (index> right-bits 6) - (aref array y (index+ x 6)) - 0) - 0))))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)) - (aref array y (index+ x 2)) - (aref array y (index+ x 3)) - (aref array y (index+ x 4)) - (aref array y (index+ x 5)) - (aref array y (index+ x 6)) - (aref array y (index+ x 7)))))))) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (index+ start-x middle-bits))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (if (index> right-bits 1) + (aref array y (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref array y (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref array y (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref array y (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref array y (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref array y (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)) + (aref array y (index+ x 2)) + (aref array y (index+ x 3)) + (aref array y (index+ x 4)) + (aref array y (index+ x 5)) + (aref array y (index+ x 6)) + (aref array y (index+ x 7)))))))) (defun write-pixarray-4 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-4 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (right-nibbles (index-mod width 2)) - (middle-nibbles (index- width right-nibbles)) - (middle-bytes (index-ceiling middle-nibbles 2)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles - middle-bytes start)) + middle-bytes start)) (do* ((end (index+ start middle-bytes)) - (i start (index1+ i)) - (start-x x) - (x start-x (index+ x 2))) - ((index>= i end) - (unless (index-zerop right-nibbles) - (setf (aref buffer-bbuf end) - (write-image-assemble-bytes - (aref array y (index+ start-x middle-nibbles)) - 0)))) - (declare (type array-index end i start-x x)) - (setf (aref buffer-bbuf i) - (write-image-assemble-bytes - (aref array y (index+ x 0)) - (aref array y (index+ x 1)))))))) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)))))))) (defun write-pixarray-8 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-8 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-8 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start width)) - (i start (index1+ i)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) + (i start (index1+ i)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) (defun write-pixarray-16 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-16 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-16 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 2))) - (i start (index+ i 2)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-16-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 16)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 16))))))) + (i start (index+ i 2)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-16-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 16)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 16))))))) (defun write-pixarray-24 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-24 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) - (i start (index+ i 3)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-24-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 24)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 24)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 24))))))) + (i start (index+ i 3)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) (defun write-pixarray-32 (buffer-bbuf index array x y width height - padded-bytes-per-line bits-per-pixel) + padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) - (type pixarray-32 array) - (type int16 x y) - (type card16 width height) - (type array-index index padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (ignore bits-per-pixel)) + (type pixarray-32 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) - (y y (index1+ y)) - (start index (index+ start padded-bytes-per-line))) - ((index>= h height)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 4))) - (i start (index+ i 4)) - (x x (index1+ x))) - ((index>= i end)) - (declare (type array-index end i x)) - (let ((pixel (aref array y x))) - (declare (type pixarray-32-element-type pixel)) - (setf (aref buffer-bbuf (index+ i 0)) - (write-image-load-byte 0 pixel 32)) - (setf (aref buffer-bbuf (index+ i 1)) - (write-image-load-byte 8 pixel 32)) - (setf (aref buffer-bbuf (index+ i 2)) - (write-image-load-byte 16 pixel 32)) - (setf (aref buffer-bbuf (index+ i 3)) - (write-image-load-byte 24 pixel 32))))))) + (i start (index+ i 4)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-32-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 32)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 32)) + (setf (aref buffer-bbuf (index+ i 3)) + (write-image-load-byte 24 pixel 32))))))) (defun write-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel write-pixarray-function - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) + bits-per-pixel write-pixarray-function + from-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type function write-pixarray-function) - (type (member 8 16 32) from-unit to-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type function write-pixarray-function) + (type (member 8 16 32) from-unit to-unit) + (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function - bits-per-pixel - from-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-unit to-byte-lsb-first-p to-bit-lsb-first-p) + bits-per-pixel + from-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) + (type generalized-boolean image-swap-lsb-first-p)) (if (eq image-swap-function 'image-noswap) - (funcall - write-pixarray-function - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel) + (funcall + write-pixarray-function + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) - (funcall - write-pixarray-function - buf 0 pixarray x y width height padded-bytes-per-line - bits-per-pixel) - (funcall - (symbol-function image-swap-function) buf bbuf 0 boffset - (index-ceiling (index* width bits-per-pixel) 8) - padded-bytes-per-line padded-bytes-per-line height - image-swap-lsb-first-p))))) + (funcall + write-pixarray-function + buf 0 pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (funcall + (symbol-function image-swap-function) buf bbuf 0 boffset + (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line padded-bytes-per-line height + image-swap-lsb-first-p))))) (defun write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) - (type pixarray pixarray) - (type card16 x y width height) - (type array-index boffset padded-bytes-per-line) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-write-pixarray - bbuf boffset pixarray x y width height padded-bytes-per-line - bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) + bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel - ( 1 #'write-pixarray-1 ) - ( 4 #'write-pixarray-4 ) - ( 8 #'write-pixarray-8 ) - (16 #'write-pixarray-16) - (24 #'write-pixarray-24) - (32 #'write-pixarray-32)) + ( 1 #'write-pixarray-1 ) + ( 4 #'write-pixarray-4 ) + ( 8 #'write-pixarray-8 ) + (16 #'write-pixarray-16) + (24 #'write-pixarray-24) + (32 #'write-pixarray-32)) +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))) (defun write-xy-format-image-x-data (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) (assert (index-zerop (index-mod x 8))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function - 1 - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + 1 + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) + (type generalized-boolean image-swap-lsb-first-p)) (let ((x-mod-unit (index-mod x from-bitmap-unit))) (declare (type card16 x-mod-unit)) (if (and (index-plusp x-mod-unit) - (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) - (let* ((temp-width (index+ width x-mod-unit)) - (temp-bytes-per-line (index-ceiling temp-width 8)) - (temp-padded-bits-per-line - (index* (index-ceiling temp-width from-bitmap-unit) - from-bitmap-unit)) - (temp-padded-bytes-per-line - (index-ceiling temp-padded-bits-per-line 8))) - (declare (type card16 temp-width temp-bytes-per-line - temp-padded-bits-per-line temp-padded-bytes-per-line)) - (with-image-data-buffer - (buf (index* height temp-padded-bytes-per-line)) - (funcall - (symbol-function image-swap-function) data buf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index- x x-mod-unit) 8)) - 0 temp-bytes-per-line from-padded-bytes-per-line - temp-padded-bytes-per-line height image-swap-lsb-first-p) - (write-xy-format-image-x-data - buf obuf 0 obuf-start x-mod-unit 0 width height - temp-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) - (funcall - (symbol-function image-swap-function) data obuf - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor x 8)) - obuf-start (index-ceiling width 8) from-padded-bytes-per-line - to-padded-bytes-per-line height image-swap-lsb-first-p))))) + (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) + (let* ((temp-width (index+ width x-mod-unit)) + (temp-bytes-per-line (index-ceiling temp-width 8)) + (temp-padded-bits-per-line + (index* (index-ceiling temp-width from-bitmap-unit) + from-bitmap-unit)) + (temp-padded-bytes-per-line + (index-ceiling temp-padded-bits-per-line 8))) + (declare (type card16 temp-width temp-bytes-per-line + temp-padded-bits-per-line temp-padded-bytes-per-line)) + (with-image-data-buffer + (buf (index* height temp-padded-bytes-per-line)) + (funcall + (symbol-function image-swap-function) data buf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index- x x-mod-unit) 8)) + 0 temp-bytes-per-line from-padded-bytes-per-line + temp-padded-bytes-per-line height image-swap-lsb-first-p) + (write-xy-format-image-x-data + buf obuf 0 obuf-start x-mod-unit 0 width height + temp-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) + (funcall + (symbol-function image-swap-function) data obuf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor x 8)) + obuf-start (index-ceiling width 8) from-padded-bytes-per-line + to-padded-bytes-per-line height image-swap-lsb-first-p))))) (defun write-xy-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dotimes (plane (image-depth image)) (let ((data-start - (index* (index* plane (image-height image)) - (image-x-bytes-per-line image))) - (src-y src-y) - (height height)) + (index* (index* plane (image-height image)) + (image-x-bytes-per-line image))) + (src-y src-y) + (height height)) (declare (type int16 src-y) - (type card16 height)) + (type card16 height)) (loop - (when (index-zerop height) (return)) - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-xy-format-image-x-data - (image-x-data image) (buffer-obuf8 display) - data-start (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) + (when (index-zerop height) (return)) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-xy-format-image-x-data + (image-x-data image) (buffer-obuf8 display) + data-start (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) (defun write-z-format-image-x-data (data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + from-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) - (type array-index data-start obuf-start - from-padded-bytes-per-line to-padded-bytes-per-line) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) - (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p - to-byte-lsb-first-p to-bit-lsb-first-p)) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) (if (index= bits-per-pixel 1) (write-xy-format-image-x-data - data obuf data-start obuf-start x y width height - from-padded-bytes-per-line to-padded-bytes-per-line - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (let ((srcoff - (index+ data-start - (index* y from-padded-bytes-per-line) - (index-floor (index* x bits-per-pixel) 8))) - (srclen (index-ceiling (index* width bits-per-pixel) 8))) + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index* x bits-per-pixel) 8))) + (srclen (index-ceiling (index* width bits-per-pixel) 8))) (declare (type array-index srcoff srclen)) (if (and (index= bits-per-pixel 4) (index-oddp x)) - (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) - (image-swap-nibbles-left - data buf srcoff 0 srclen - from-padded-bytes-per-line to-padded-bytes-per-line height nil) - (write-z-format-image-x-data - buf obuf 0 obuf-start 0 0 width height - to-padded-bytes-per-line to-padded-bytes-per-line - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) - (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p - to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) data obuf srcoff obuf-start - srclen from-padded-bytes-per-line to-padded-bytes-per-line height - image-swap-lsb-first-p)))))) + (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) + (image-swap-nibbles-left + data buf srcoff 0 srclen + from-padded-bytes-per-line to-padded-bytes-per-line height nil) + (write-z-format-image-x-data + buf obuf 0 obuf-start 0 0 width height + to-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) + (multiple-value-bind (image-swap-function image-swap-lsb-first-p) + (image-swap-function + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (funcall + (symbol-function image-swap-function) data obuf srcoff obuf-start + srclen from-padded-bytes-per-line to-padded-bytes-per-line height + image-swap-lsb-first-p)))))) (defun write-z-format-image-x (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) - (type image-x image) - (type int16 src-x src-y) - (type card16 width height) - (type array-index padded-bytes-per-line) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (when (index-zerop height) (return)) (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) (declare (type array-index nlines)) (when (index-plusp nlines) - (write-z-format-image-x-data - (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) - src-x src-y width nlines - (image-x-bytes-per-line image) padded-bytes-per-line - (image-x-bits-per-pixel image) - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) + (write-z-format-image-x-data + (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-bits-per-pixel image) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) (defun write-image-xy (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) - (type image-xy image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type image-xy image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dolist (bitmap (image-xy-bitmap-list image)) (declare (type pixarray-1 bitmap)) (let ((src-y src-y) - (height height)) + (height height)) (declare (type int16 src-y) - (type card16 height)) + (type card16 height)) (loop - (let ((nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) - (declare (type array-index nlines)) - (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - bitmap src-x src-y width nlines - padded-bytes-per-line 1 - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) - (buffer-flush display))))) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-pixarray + (buffer-obuf8 display) (buffer-boffset display) + bitmap src-x src-y width nlines + padded-bytes-per-line 1 + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) (defun write-image-z (display image src-x src-y width height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p) + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) - (type image-z image) - (type array-index padded-bytes-per-line) - (type int16 src-x src-y) - (type card16 width height) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type image-z image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (let ((bits-per-pixel (image-z-bits-per-pixel image)) - (nlines - (index-min (index-floor (index- (buffer-size display) - (buffer-boffset display)) - padded-bytes-per-line) - height))) + (nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) - (type array-index nlines)) + (type array-index nlines)) (when (index-plusp nlines) - (write-pixarray - (buffer-obuf8 display) (buffer-boffset display) - (image-z-pixarray image) src-x src-y width nlines - padded-bytes-per-line bits-per-pixel - unit byte-lsb-first-p bit-lsb-first-p) - (index-incf (buffer-boffset display) - (index* nlines padded-bytes-per-line)) - (index-incf src-y nlines) - (when (index-zerop (index-decf height nlines)) (return)))) + (write-pixarray + (buffer-obuf8 display) (buffer-boffset display) + (image-z-pixarray image) src-x src-y width nlines + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) -;;; Note: The only difference between a format of :bitmap and :xy-pixmap -;;; of depth 1 is that when sending a :bitmap format the foreground -;;; and background in the gcontext are used. +;;; Note: The only difference between a format of :bitmap and :xy-pixmap +;;; of depth 1 is that when sending a :bitmap format the foreground +;;; and background in the gcontext are used. (defun put-image (drawable gcontext image &key - (src-x 0) (src-y 0) ;Position within image - (x (required-arg x)) ;Position within drawable - (y (required-arg y)) - width height - bitmap-p) + (src-x 0) (src-y 0) ;Position within image + (x (required-arg x)) ;Position within drawable + (y (required-arg y)) + width height + bitmap-p) ;; Copy an image into a drawable. ;; WIDTH and HEIGHT default from IMAGE. ;; When BITMAP-P, force format to be :bitmap when depth=1. ;; This causes gcontext to supply foreground & background pixels. (declare (type drawable drawable) - (type gcontext gcontext) - (type image image) - (type int16 x y) ;; required - (type int16 src-x src-y) - (type (or null card16) width height) - (type generalized-boolean bitmap-p)) + (type gcontext gcontext) + (type image image) + (type int16 x y) ;; required + (type int16 src-x src-y) + (type (or null card16) width height) + (type generalized-boolean bitmap-p)) (let* ((format - (etypecase image - (image-x (image-x-format (the image-x image))) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (src-x - (if (image-x-p image) - (index+ src-x (image-x-left-pad (the image-x image))) - src-x)) - (image-width (image-width image)) - (image-height (image-height image)) - (width (min (or width image-width) (index- image-width src-x))) - (height (min (or height image-height) (index- image-height src-y))) - (depth (image-depth image)) - (display (drawable-display drawable)) - (bitmap-format (display-bitmap-format display)) - (unit (bitmap-format-unit bitmap-format)) - (byte-lsb-first-p (display-image-lsb-first-p display)) - (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (etypecase image + (image-x (image-x-format (the image-x image))) + (image-xy :xy-pixmap) + (image-z :z-pixmap))) + (src-x + (if (image-x-p image) + (index+ src-x (image-x-left-pad (the image-x image))) + src-x)) + (image-width (image-width image)) + (image-height (image-height image)) + (width (min (or width image-width) (index- image-width src-x))) + (height (min (or height image-height) (index- image-height src-y))) + (depth (image-depth image)) + (display (drawable-display drawable)) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) - (type fixnum src-x image-width image-height width height) - (type image-depth depth) - (type display display) - (type bitmap-format bitmap-format) - (type (member 8 16 32) unit) - (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) + (type fixnum src-x image-width image-height width height) + (type image-depth depth) + (type display display) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (when (and bitmap-p (not (index= depth 1))) (error "Bitmaps must have depth 1")) (unless (<= 0 src-x (index1- (image-width image))) @@ -1974,163 +1974,163 @@ (error "src-y not inside image")) (when (and (index> width 0) (index> height 0)) (multiple-value-bind (pad bits-per-pixel) - (ecase format - ((:bitmap :xy-pixmap) - (values (bitmap-format-pad bitmap-format) 1)) - (:z-pixmap - (if (= depth 1) - (values (bitmap-format-pad bitmap-format) 1) - (let ((pixmap-format - (find depth (display-pixmap-formats display) - :key #'pixmap-format-depth))) - (declare (type (or null pixmap-format) pixmap-format)) - (if (null pixmap-format) - (error "The depth of the image ~s does not match any server pixmap format." image)) - (if (not (= (etypecase image - (image-z (image-z-bits-per-pixel image)) - (image-x (image-x-bits-per-pixel image))) - (pixmap-format-bits-per-pixel pixmap-format))) - ;; We could try to use the "/* XXX slow, but works */" - ;; code in XPutImage from X11R4 here. However, that - ;; would require considerable support code - ;; (see XImUtil.c, etc). - (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) - (values (pixmap-format-scanline-pad pixmap-format) - (pixmap-format-bits-per-pixel pixmap-format)))))) - (declare (type (member 8 16 32) pad) - (type (member 1 4 8 16 24 32) bits-per-pixel)) - (let* ((left-pad - (if (or (eq format :xy-pixmap) (= depth 1)) - (index-mod src-x (index-min pad +image-pad+)) - 0)) - (left-padded-src-x (index- src-x left-pad)) - (left-padded-width (index+ width left-pad)) - (bits-per-line (index* left-padded-width bits-per-pixel)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (request-bytes-per-line - (ecase format - ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) - (:z-pixmap padded-bytes-per-line))) - (max-bytes-per-request - (index* (index- (display-max-request-length display) 6) 4)) - (max-request-height - (floor max-bytes-per-request request-bytes-per-line))) - (declare (type card8 left-pad) - (type int16 left-padded-src-x) - (type card16 left-padded-width) - (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line request-bytes-per-line - max-bytes-per-request max-request-height)) - ;; Be sure that a scanline can fit in a request - (when (index-zerop max-request-height) - (error "Can't even fit one image scanline in a request")) - ;; Be sure a scanline can fit in a buffer - (buffer-ensure-size display padded-bytes-per-line) - ;; Send the image in multiple requests to avoid exceeding the - ;; request limit - (do* ((request-src-y src-y (index+ request-src-y request-height)) - (request-y y (index+ request-y request-height)) - (height-remaining - height (the fixnum (- height-remaining request-height))) - (request-height - (index-min height-remaining max-request-height) - (index-min height-remaining max-request-height))) - ((<= height-remaining 0)) - (declare (type array-index request-src-y request-height) - (fixnum height-remaining)) - (let* ((request-bytes (index* request-bytes-per-line request-height)) - (request-words (index-ceiling request-bytes 4)) - (request-length (index+ request-words 6))) - (declare (type array-index request-bytes) - (type card16 request-words request-length)) - (with-buffer-request (display +x-putimage+ :gc-force gcontext) - ((data (member :bitmap :xy-pixmap :z-pixmap)) - (cond ((or (eq format :bitmap) bitmap-p) :bitmap) - ((plusp left-pad) :xy-pixmap) - (t format))) - (drawable drawable) - (gcontext gcontext) - (card16 width request-height) - (int16 x request-y) - (card8 left-pad depth) - (pad16 nil) - (progn - (length-put 2 request-length) - (setf (buffer-boffset display) (advance-buffer-offset 24)) - (etypecase image - (image-x - (ecase (image-x-format (the image-x image)) - ((:bitmap :xy-pixmap) - (write-xy-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (:z-pixmap - (write-z-format-image-x - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)))) - (image-xy - (write-image-xy - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p)) - (image-z - (write-image-z - display image left-padded-src-x request-src-y - left-padded-width request-height - padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p))) - ;; Be sure the request is padded to a multiple of 4 bytes - (buffer-pad-request display (index- (index* request-words 4) request-bytes)) - ))))))))) + (ecase format + ((:bitmap :xy-pixmap) + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type (or null pixmap-format) pixmap-format)) + (if (null pixmap-format) + (error "The depth of the image ~s does not match any server pixmap format." image)) + (if (not (= (etypecase image + (image-z (image-z-bits-per-pixel image)) + (image-x (image-x-bits-per-pixel image))) + (pixmap-format-bits-per-pixel pixmap-format))) + ;; We could try to use the "/* XXX slow, but works */" + ;; code in XPutImage from X11R4 here. However, that + ;; would require considerable support code + ;; (see XImUtil.c, etc). + (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((left-pad + (if (or (eq format :xy-pixmap) (= depth 1)) + (index-mod src-x (index-min pad +image-pad+)) + 0)) + (left-padded-src-x (index- src-x left-pad)) + (left-padded-width (index+ width left-pad)) + (bits-per-line (index* left-padded-width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (request-bytes-per-line + (ecase format + ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) + (:z-pixmap padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4)) + (max-request-height + (floor max-bytes-per-request request-bytes-per-line))) + (declare (type card8 left-pad) + (type int16 left-padded-src-x) + (type card16 left-padded-width) + (type array-index bits-per-line padded-bits-per-line + padded-bytes-per-line request-bytes-per-line + max-bytes-per-request max-request-height)) + ;; Be sure that a scanline can fit in a request + (when (index-zerop max-request-height) + (error "Can't even fit one image scanline in a request")) + ;; Be sure a scanline can fit in a buffer + (buffer-ensure-size display padded-bytes-per-line) + ;; Send the image in multiple requests to avoid exceeding the + ;; request limit + (do* ((request-src-y src-y (index+ request-src-y request-height)) + (request-y y (index+ request-y request-height)) + (height-remaining + height (the fixnum (- height-remaining request-height))) + (request-height + (index-min height-remaining max-request-height) + (index-min height-remaining max-request-height))) + ((<= height-remaining 0)) + (declare (type array-index request-src-y request-height) + (fixnum height-remaining)) + (let* ((request-bytes (index* request-bytes-per-line request-height)) + (request-words (index-ceiling request-bytes 4)) + (request-length (index+ request-words 6))) + (declare (type array-index request-bytes) + (type card16 request-words request-length)) + (with-buffer-request (display +x-putimage+ :gc-force gcontext) + ((data (member :bitmap :xy-pixmap :z-pixmap)) + (cond ((or (eq format :bitmap) bitmap-p) :bitmap) + ((plusp left-pad) :xy-pixmap) + (t format))) + (drawable drawable) + (gcontext gcontext) + (card16 width request-height) + (int16 x request-y) + (card8 left-pad depth) + (pad16 nil) + (progn + (length-put 2 request-length) + (setf (buffer-boffset display) (advance-buffer-offset 24)) + (etypecase image + (image-x + (ecase (image-x-format (the image-x image)) + ((:bitmap :xy-pixmap) + (write-xy-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (:z-pixmap + (write-z-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)))) + (image-xy + (write-image-xy + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (write-image-z + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p))) + ;; Be sure the request is padded to a multiple of 4 bytes + (buffer-pad-request display (index- (index* request-words 4) request-bytes)) + ))))))))) ;;;----------------------------------------------------------------------------- ;;; COPY-IMAGE (defun xy-format-image-x->image-x (image x y width height) (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) + (type card16 x y width height) + (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad (index-mod padded-x 8)) - (x (index- padded-x left-pad)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (padded-width - (index* (index-ceiling (index+ width left-pad) pad) pad)) - (padded-bytes-per-line (index-ceiling padded-width 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) + (left-pad (index-mod padded-x 8)) + (x (index- padded-x left-pad)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (padded-width + (index* (index-ceiling (index+ width left-pad) pad) pad)) + (padded-bytes-per-line (index-ceiling padded-width 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index padded-width padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index padded-width padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) (dotimes (plane (image-depth image)) (let ((data-start - (index* (image-x-bytes-per-line image) - (image-height image) - plane)) - (obuf-start - (index* padded-bytes-per-plane - plane))) - (declare (type array-index data-start obuf-start)) - (write-xy-format-image-x-data - (image-x-data image) obuf data-start obuf-start - x y width height - (image-x-bytes-per-line image) padded-bytes-per-line - unit byte-lsb-first-p bit-lsb-first-p - unit byte-lsb-first-p bit-lsb-first-p))) + (index* (image-x-bytes-per-line image) + (image-height image) + plane)) + (obuf-start + (index* padded-bytes-per-plane + plane))) + (declare (type array-index data-start obuf-start)) + (write-xy-format-image-x-data + (image-x-data image) obuf data-start obuf-start + x y width height + (image-x-bytes-per-line image) padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth (image-depth image) :data obuf :format (image-x-format image) :bits-per-pixel 1 @@ -2140,31 +2140,31 @@ (defun z-format-image-x->image-x (image x y width height) (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) + (type card16 x y width height) + (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) - (left-pad - (if (index= (image-depth image) 1) - (index-mod padded-x 8) - 0)) - (x (index- padded-x left-pad)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (unit (image-x-unit image)) - (byte-lsb-first-p (image-x-byte-lsb-first-p image)) - (bit-lsb-first-p (image-x-bit-lsb-first-p image)) - (pad (image-x-pad image)) - (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) - (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (length (index* padded-bytes-per-plane (image-depth image))) - (obuf (make-array length :element-type 'card8))) + (left-pad + (if (index= (image-depth image) 1) + (index-mod padded-x 8) + 0)) + (x (index- padded-x left-pad)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) + (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) (declare (type card16 x) - (type card8 left-pad) - (type (member 8 16 32) unit pad) - (type array-index bits-per-pixel padded-bytes-per-line - padded-bytes-per-plane length) - (type buffer-bytes obuf)) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index bits-per-pixel padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) (write-z-format-image-x-data (image-x-data image) obuf 0 0 x y width height @@ -2181,8 +2181,8 @@ (defun image-x->image-x (image x y width height) (declare (type image-x image) - (type card16 x y width height) - (clx-values image-x)) + (type card16 x y width height) + (clx-values image-x)) (ecase (image-x-format image) ((:bitmap :xy-pixmap) (xy-format-image-x->image-x image x y width height)) @@ -2191,14 +2191,14 @@ (defun image-x->image-xy (image x y width height) (declare (type image-x image) - (type card16 x y width height) - (clx-values image-xy)) + (type card16 x y width height) + (clx-values image-xy)) (unless (or (eq (image-x-format image) :bitmap) - (eq (image-x-format image) :xy-pixmap) - (and (eq (image-x-format image) :z-pixmap) - (index= (image-depth image) 1))) + (eq (image-x-format image) :xy-pixmap) + (and (eq (image-x-format image) :z-pixmap) + (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :xy-pixmap)) + (image-x-format image) :xy-pixmap)) (read-image-xy (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height @@ -2209,14 +2209,14 @@ (defun image-x->image-z (image x y width height) (declare (type image-x image) - (type card16 x y width height) - (clx-values image-z)) + (type card16 x y width height) + (clx-values image-z)) (unless (or (eq (image-x-format image) :z-pixmap) - (eq (image-x-format image) :bitmap) - (and (eq (image-x-format image) :xy-pixmap) - (index= (image-depth image) 1))) + (eq (image-x-format image) :bitmap) + (and (eq (image-x-format image) :xy-pixmap) + (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" - (image-x-format image) :z-pixmap)) + (image-x-format image) :z-pixmap)) (read-image-z (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height @@ -2227,64 +2227,64 @@ (defun copy-pixarray (array x y width height bits-per-pixel) (declare (type pixarray array) - (type card16 x y width height) - (type (member 1 4 8 16 24 32) bits-per-pixel)) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) - (copy (make-array (list height padded-width) - :element-type (array-element-type array)))) + (padded-bits-per-line + (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) + (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) + (copy (make-array (list height padded-width) + :element-type (array-element-type array)))) (declare (type array-index bits-per-line padded-bits-per-line padded-width) - (type pixarray copy)) + (type pixarray copy)) #.(declare-buffun) (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) (macrolet - ((copy (array-type element-type) - `(let ((array array) - (copy copy)) - (declare (type ,array-type array copy)) - (do* ((dst-y 0 (index1+ dst-y)) - (src-y y (index1+ src-y))) - ((index>= dst-y height)) - (declare (type card16 dst-y src-y)) - (do* ((dst-x 0 (index1+ dst-x)) - (src-x x (index1+ src-x))) - ((index>= dst-x width)) - (declare (type card16 dst-x src-x)) - (setf (aref copy dst-y dst-x) - (the ,element-type - (aref array src-y src-x)))))))) - (ecase bits-per-pixel - (1 (copy pixarray-1 pixarray-1-element-type)) - (4 (copy pixarray-4 pixarray-4-element-type)) - (8 (copy pixarray-8 pixarray-8-element-type)) - (16 (copy pixarray-16 pixarray-16-element-type)) - (24 (copy pixarray-24 pixarray-24-element-type)) - (32 (copy pixarray-32 pixarray-32-element-type))))) + ((copy (array-type element-type) + `(let ((array array) + (copy copy)) + (declare (type ,array-type array copy)) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-x 0 (index1+ dst-x)) + (src-x x (index1+ src-x))) + ((index>= dst-x width)) + (declare (type card16 dst-x src-x)) + (setf (aref copy dst-y dst-x) + (the ,element-type + (aref array src-y src-x)))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))))) copy)) (defun image-xy->image-x (image x y width height) (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-x)) + (type card16 x y width height) + (clx-values image-x)) (let* ((padded-bits-per-line - (index* (index-ceiling width +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (padded-bytes-per-plane (index* padded-bytes-per-line height)) - (bytes-total (index* padded-bytes-per-plane (image-depth image))) - (data (make-array bytes-total :element-type 'card8))) + (index* (index-ceiling width +image-pad+) +image-pad+)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (bytes-total (index* padded-bytes-per-plane (image-depth image))) + (data (make-array bytes-total :element-type 'card8))) (declare (type array-index padded-bits-per-line padded-bytes-per-line - padded-bytes-per-plane bytes-total) - (type buffer-bytes data)) + padded-bytes-per-plane bytes-total) + (type buffer-bytes data)) (let ((index 0)) (declare (type array-index index)) (dolist (bitmap (image-xy-bitmap-list image)) - (declare (type pixarray-1 bitmap)) - (write-pixarray - data index bitmap x y width height padded-bytes-per-line 1 - +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) - (index-incf index padded-bytes-per-plane))) + (declare (type pixarray-1 bitmap)) + (write-pixarray + data index bitmap x y width height padded-bytes-per-line 1 + +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) + (index-incf index padded-bytes-per-plane))) (create-image :width width :height height :depth (image-depth image) :data data :format :xy-pixmap :bits-per-pixel 1 @@ -2295,39 +2295,39 @@ (defun image-xy->image-xy (image x y width height) (declare (type image-xy image) - (type card16 x y width height) - (clx-values image-xy)) + (type card16 x y width height) + (clx-values image-xy)) (create-image :width width :height height :depth (image-depth image) :data (mapcar - #'(lambda (array) - (declare (type pixarray-1 array)) - (copy-pixarray array x y width height 1)) - (image-xy-bitmap-list image)))) + #'(lambda (array) + (declare (type pixarray-1 array)) + (copy-pixarray array x y width height 1)) + (image-xy-bitmap-list image)))) (defun image-xy->image-z (image x y width height) (declare (type image-xy image) - (type card16 x y width height) - (ignore image x y width height)) + (type card16 x y width height) + (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" - :xy-pixmap :z-pixmap)) + :xy-pixmap :z-pixmap)) (defun image-z->image-x (image x y width height) (declare (type image-z image) - (type card16 x y width height) - (clx-values image-x)) + (type card16 x y width height) + (clx-values image-x)) (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) - (padded-bits-per-line - (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) - (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) - (bytes-total - (index* padded-bytes-per-line height (image-depth image))) - (data (make-array bytes-total :element-type 'card8)) - (bits-per-pixel (image-z-bits-per-pixel image))) + (padded-bits-per-line + (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (bytes-total + (index* padded-bytes-per-line height (image-depth image))) + (data (make-array bytes-total :element-type 'card8)) + (bits-per-pixel (image-z-bits-per-pixel image))) (declare (type array-index bits-per-line padded-bits-per-line - padded-bytes-per-line bytes-total) - (type buffer-bytes data) - (type (member 1 4 8 16 24 32) bits-per-pixel)) + padded-bytes-per-line bytes-total) + (type buffer-bytes data) + (type (member 1 4 8 16 24 32) bits-per-pixel)) (write-pixarray data 0 (image-z-pixarray image) x y width height padded-bytes-per-line (image-z-bits-per-pixel image) @@ -2343,33 +2343,33 @@ (defun image-z->image-xy (image x y width height) (declare (type image-z image) - (type card16 x y width height) - (ignore image x y width height)) + (type card16 x y width height) + (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" - :z-pixmap :xy-pixmap)) + :z-pixmap :xy-pixmap)) (defun image-z->image-z (image x y width height) (declare (type image-z image) - (type card16 x y width height) - (clx-values image-z)) + (type card16 x y width height) + (clx-values image-z)) (create-image :width width :height height :depth (image-depth image) :data (copy-pixarray - (image-z-pixarray image) x y width height - (image-z-bits-per-pixel image)))) + (image-z-pixarray image) x y width height + (image-z-bits-per-pixel image)))) (defun copy-image (image &key (x 0) (y 0) width height result-type) ;; Copy with optional sub-imaging and format conversion. ;; result-type defaults to (type-of image) (declare (type image image) - (type card16 x y) - (type (or null card16) width height) ;; Default from image - (type (or null (member image-x image-xy image-z)) result-type)) + (type card16 x y) + (type (or null card16) width height) ;; Default from image + (type (or null (member image-x image-xy image-z)) result-type)) (declare (clx-values image)) (let* ((image-width (image-width image)) - (image-height (image-height image)) - (width (or width image-width)) - (height (or height image-height))) + (image-height (image-height image)) + (width (or width image-width)) + (height (or height image-height))) (declare (type card16 image-width image-height width height)) (unless (<= 0 x (the fixnum (1- image-width))) (error "x not inside image")) @@ -2378,28 +2378,28 @@ (setq width (index-min width (max (the fixnum (- image-width x)) 0))) (setq height (index-min height (max (the fixnum (- image-height y)) 0))) (let ((copy - (etypecase image - (image-x - (ecase result-type - ((nil image-x) (image-x->image-x image x y width height)) - (image-xy (image-x->image-xy image x y width height)) - (image-z (image-x->image-z image x y width height)))) - (image-xy - (ecase result-type - (image-x (image-xy->image-x image x y width height)) - ((nil image-xy) (image-xy->image-xy image x y width height)) - (image-z (image-xy->image-z image x y width height)))) - (image-z - (ecase result-type - (image-x (image-z->image-x image x y width height)) - (image-xy (image-z->image-xy image x y width height)) - ((nil image-z) (image-z->image-z image x y width height))))))) + (etypecase image + (image-x + (ecase result-type + ((nil image-x) (image-x->image-x image x y width height)) + (image-xy (image-x->image-xy image x y width height)) + (image-z (image-x->image-z image x y width height)))) + (image-xy + (ecase result-type + (image-x (image-xy->image-x image x y width height)) + ((nil image-xy) (image-xy->image-xy image x y width height)) + (image-z (image-xy->image-z image x y width height)))) + (image-z + (ecase result-type + (image-x (image-z->image-x image x y width height)) + (image-xy (image-z->image-xy image x y width height)) + ((nil image-z) (image-z->image-z image x y width height))))))) (declare (type image copy)) (setf (image-plist copy) (copy-list (image-plist image))) (when (and (image-x-hot image) (not (index-zerop x))) - (setf (image-x-hot copy) (index- (image-x-hot image) x))) + (setf (image-x-hot copy) (index- (image-x-hot image) x))) (when (and (image-y-hot image) (not (index-zerop y))) - (setf (image-y-hot copy) (index- (image-y-hot image) y))) + (setf (image-y-hot copy) (index- (image-y-hot image) y))) copy))) @@ -2413,133 +2413,133 @@ (declare (clx-values image)) (with-open-file (fstream pathname :direction :input) (let ((line "") - (properties nil) - (name nil) - (name-end nil)) + (properties nil) + (name nil) + (name-end nil)) (declare (type string line) - (type stringable name) - (type list properties)) + (type stringable name) + (type list properties)) ;; Get properties (loop - (setq line (read-line fstream)) - (unless (char= (aref line 0) #\#) (return)) - (flet ((read-keyword (line start end) - (kintern - (substitute - #\- #\_ - (#-excl string-upcase - #+excl correct-case - (subseq line start end)) - :test #'char=)))) - (when (null name) - (setq name-end (position #\_ line :test #'char= :from-end t) - name (read-keyword line 8 name-end)) - (unless (eq name :image) - (setf (getf properties :name) name))) - (let* ((ind-start (index1+ name-end)) - (ind-end (position #\Space line :test #'char= - :start ind-start)) - (ind (read-keyword line ind-start ind-end)) - (val-start (index1+ ind-end)) - (val (parse-integer line :start val-start))) - (setf (getf properties ind) val)))) + (setq line (read-line fstream)) + (unless (char= (aref line 0) #\#) (return)) + (flet ((read-keyword (line start end) + (kintern + (substitute + #\- #\_ + (#-excl string-upcase + #+excl correct-case + (subseq line start end)) + :test #'char=)))) + (when (null name) + (setq name-end (position #\_ line :test #'char= :from-end t) + name (read-keyword line 8 name-end)) + (unless (eq name :image) + (setf (getf properties :name) name))) + (let* ((ind-start (index1+ name-end)) + (ind-end (position #\Space line :test #'char= + :start ind-start)) + (ind (read-keyword line ind-start ind-end)) + (val-start (index1+ ind-end)) + (val (parse-integer line :start val-start))) + (setf (getf properties ind) val)))) ;; Calculate sizes (multiple-value-bind (width height depth left-pad) - (flet ((extract-property (ind &rest default) - (prog1 (apply #'getf properties ind default) - (remf properties ind)))) - (values (extract-property :width) - (extract-property :height) - (extract-property :depth 1) - (extract-property :left-pad 0))) - (declare (type (or null card16) width height) - (type image-depth depth) - (type card8 left-pad)) - (unless (and width height) (error "Not a BITMAP file")) - (let* ((bits-per-pixel - (cond ((index> depth 24) 32) - ((index> depth 16) 24) - ((index> depth 8) 16) - ((index> depth 4) 8) - ((index> depth 1) 4) - (t 1))) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (padded-bits-per-line - (index* (index-ceiling bits-per-line 32) 32)) - (padded-bytes-per-line - (index-ceiling padded-bits-per-line 8)) - (data (make-array (* padded-bytes-per-line height) - :element-type 'card8)) - (line-base 0) - (byte 0)) - (declare (type array-index bits-per-line bytes-per-line - padded-bits-per-line padded-bytes-per-line - line-base byte) - (type buffer-bytes data)) - (with-vector (data buffer-bytes) - (flet ((parse-hex (char) - (second - (assoc char - '((#\0 0) (#\1 1) (#\2 2) (#\3 3) - (#\4 4) (#\5 5) (#\6 6) (#\7 7) - (#\8 8) (#\9 9) (#\a 10) (#\b 11) - (#\c 12) (#\d 13) (#\e 14) (#\f 15)) - :test #'char-equal)))) - (declare (inline parse-hex)) - ;; Read data - ;; Note: using read-line instead of read-char would be 20% faster, - ;; but would cons a lot of garbage... - (dotimes (i height) - (dotimes (j bytes-per-line) - (loop (when (eql (read-char fstream) #\x) (return))) - (setf (aref data (index+ line-base byte)) - (index+ (index-ash (parse-hex (read-char fstream)) 4) - (parse-hex (read-char fstream)))) - (incf byte)) - (setq byte 0 - line-base (index+ line-base padded-bytes-per-line))))) - ;; Compensate for left-pad in width and x-hot - (index-decf width left-pad) - (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) - (index-decf (getf properties :x-hot) left-pad)) - (create-image - :width width :height height - :depth depth :bits-per-pixel bits-per-pixel - :data data :plist properties :format :z-pixmap - :bytes-per-line padded-bytes-per-line - :unit 32 :pad 32 :left-pad left-pad - :byte-lsb-first-p t :bit-lsb-first-p t)))))) + (flet ((extract-property (ind &rest default) + (prog1 (apply #'getf properties ind default) + (remf properties ind)))) + (values (extract-property :width) + (extract-property :height) + (extract-property :depth 1) + (extract-property :left-pad 0))) + (declare (type (or null card16) width height) + (type image-depth depth) + (type card8 left-pad)) + (unless (and width height) (error "Not a BITMAP file")) + (let* ((bits-per-pixel + (cond ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1))) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line 32) 32)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (data (make-array (* padded-bytes-per-line height) + :element-type 'card8)) + (line-base 0) + (byte 0)) + (declare (type array-index bits-per-line bytes-per-line + padded-bits-per-line padded-bytes-per-line + line-base byte) + (type buffer-bytes data)) + (with-vector (data buffer-bytes) + (flet ((parse-hex (char) + (second + (assoc char + '((#\0 0) (#\1 1) (#\2 2) (#\3 3) + (#\4 4) (#\5 5) (#\6 6) (#\7 7) + (#\8 8) (#\9 9) (#\a 10) (#\b 11) + (#\c 12) (#\d 13) (#\e 14) (#\f 15)) + :test #'char-equal)))) + (declare (inline parse-hex)) + ;; Read data + ;; Note: using read-line instead of read-char would be 20% faster, + ;; but would cons a lot of garbage... + (dotimes (i height) + (dotimes (j bytes-per-line) + (loop (when (eql (read-char fstream) #\x) (return))) + (setf (aref data (index+ line-base byte)) + (index+ (index-ash (parse-hex (read-char fstream)) 4) + (parse-hex (read-char fstream)))) + (incf byte)) + (setq byte 0 + line-base (index+ line-base padded-bytes-per-line))))) + ;; Compensate for left-pad in width and x-hot + (index-decf width left-pad) + (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) + (index-decf (getf properties :x-hot) left-pad)) + (create-image + :width width :height height + :depth depth :bits-per-pixel bits-per-pixel + :data data :plist properties :format :z-pixmap + :bytes-per-line padded-bytes-per-line + :unit 32 :pad 32 :left-pad left-pad + :byte-lsb-first-p t :bit-lsb-first-p t)))))) (defun write-bitmap-file (pathname image &optional name) ;; Writes an image to a C include file in standard X11 format ;; NAME argument used for variable prefixes. Defaults to "image" (declare (type (or pathname string stream) pathname) - (type image image) - (type (or null stringable) name)) + (type image image) + (type (or null stringable) name)) (unless (typep image 'image-x) (setq image (copy-image image :result-type 'image-x))) (let* ((plist (image-plist image)) - (name (or name (image-name image) 'image)) - (left-pad (image-x-left-pad image)) - (width (index+ (image-width image) left-pad)) - (height (image-height image)) - (depth - (if (eq (image-x-format image) :z-pixmap) - (image-depth image) - 1)) - (bits-per-pixel (image-x-bits-per-pixel image)) - (bits-per-line (index* width bits-per-pixel)) - (bytes-per-line (index-ceiling bits-per-line 8)) - (last (index* bytes-per-line height)) - (count 0)) + (name (or name (image-name image) 'image)) + (left-pad (image-x-left-pad image)) + (width (index+ (image-width image) left-pad)) + (height (image-height image)) + (depth + (if (eq (image-x-format image) :z-pixmap) + (image-depth image) + 1)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (last (index* bytes-per-line height)) + (count 0)) (declare (type list plist) - (type stringable name) - (type card8 left-pad) - (type card16 width height) - (type (member 1 4 8 16 24 32) bits-per-pixel) - (type image-depth depth) - (type array-index bits-per-line bytes-per-line count last)) + (type stringable name) + (type card8 left-pad) + (type card16 width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type image-depth depth) + (type array-index bits-per-line bytes-per-line count last)) ;; Move x-hot by left-pad, if there is an x-hot, so image readers that ;; don't know about left pad get the hot spot in the right place. We have ;; already increased width by left-pad. @@ -2548,74 +2548,74 @@ (index-incf (getf plist :x-hot) left-pad)) (with-image-data-buffer (data last) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) - (image-swap-function - bits-per-pixel - (image-x-unit image) (image-x-byte-lsb-first-p image) - (image-x-bit-lsb-first-p image) 32 t t) - (declare (type symbol image-swap-function) - (type generalized-boolean image-swap-lsb-first-p)) - (funcall - (symbol-function image-swap-function) (image-x-data image) - data 0 0 bytes-per-line (image-x-bytes-per-line image) - bytes-per-line height image-swap-lsb-first-p)) + (image-swap-function + bits-per-pixel + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) 32 t t) + (declare (type symbol image-swap-function) + (type generalized-boolean image-swap-lsb-first-p)) + (funcall + (symbol-function image-swap-function) (image-x-data image) + data 0 0 bytes-per-line (image-x-bytes-per-line image) + bytes-per-line height image-swap-lsb-first-p)) (with-vector (data buffer-bytes) - (setq name (string-downcase (string name))) - (with-open-file (fstream pathname :direction :output) - (format fstream "#define ~a_width ~d~%" name width) - (format fstream "#define ~a_height ~d~%" name height) - (unless (= depth 1) - (format fstream "#define ~a_depth ~d~%" name depth)) - (unless (zerop left-pad) - (format fstream "#define ~a_left_pad ~d~%" name left-pad)) - (do ((prop plist (cddr prop))) - ((endp prop)) - (when (and (not (member (car prop) '(:width :height))) - (numberp (cadr prop))) - (format fstream "#define ~a_~a ~d~%" - name - (substitute - #\_ #\- (string-downcase (string (car prop))) - :test #'char=) - (cadr prop)))) - (format fstream "static char ~a_bits[] = {" name) - (dotimes (i height) - (dotimes (j bytes-per-line) - (when (zerop (index-mod count 15)) - (terpri fstream) - (write-char #\space fstream)) - (write-string "0x" fstream) - ;; Faster than (format fstream "0x~2,'0x," byte) - (let ((byte (aref data count)) - (translate "0123456789abcdef")) - (declare (type card8 byte)) - (write-char (char translate (ldb (byte 4 4) byte)) fstream) - (write-char (char translate (ldb (byte 4 0) byte)) fstream)) - (index-incf count) - (unless (index= count last) - (write-char #\, fstream)))) - (format fstream "};~%")))))) + (setq name (string-downcase (string name))) + (with-open-file (fstream pathname :direction :output) + (format fstream "#define ~a_width ~d~%" name width) + (format fstream "#define ~a_height ~d~%" name height) + (unless (= depth 1) + (format fstream "#define ~a_depth ~d~%" name depth)) + (unless (zerop left-pad) + (format fstream "#define ~a_left_pad ~d~%" name left-pad)) + (do ((prop plist (cddr prop))) + ((endp prop)) + (when (and (not (member (car prop) '(:width :height))) + (numberp (cadr prop))) + (format fstream "#define ~a_~a ~d~%" + name + (substitute + #\_ #\- (string-downcase (string (car prop))) + :test #'char=) + (cadr prop)))) + (format fstream "static char ~a_bits[] = {" name) + (dotimes (i height) + (dotimes (j bytes-per-line) + (when (zerop (index-mod count 15)) + (terpri fstream) + (write-char #\space fstream)) + (write-string "0x" fstream) + ;; Faster than (format fstream "0x~2,'0x," byte) + (let ((byte (aref data count)) + (translate "0123456789abcdef")) + (declare (type card8 byte)) + (write-char (char translate (ldb (byte 4 4) byte)) fstream) + (write-char (char translate (ldb (byte 4 0) byte)) fstream)) + (index-incf count) + (unless (index= count last) + (write-char #\, fstream)))) + (format fstream "};~%")))))) (defun bitmap-image (&optional plist &rest patterns) ;; Create an image containg pattern ;; PATTERNS are bit-vector constants (e.g. #*10101) ;; If the first parameter is a list, its used as the image property-list. (declare (type (or list bit-vector) plist) - (type list patterns)) ;; list of bitvector + (type list patterns)) ;; list of bitvector (declare (clx-values image)) (unless (listp plist) (push plist patterns) (setq plist nil)) (let* ((width (length (first patterns))) - (height (length patterns)) - (bitarray (make-array (list height width) :element-type 'bit)) - (row 0)) + (height (length patterns)) + (bitarray (make-array (list height width) :element-type 'bit)) + (row 0)) (declare (type card16 width height row) - (type pixarray-1 bitarray)) + (type pixarray-1 bitarray)) (dolist (pattern patterns) (declare (type simple-bit-vector pattern)) (dotimes (col width) - (declare (type card16 col)) - (setf (aref bitarray row col) (the bit (aref pattern col)))) + (declare (type card16 col)) + (setf (aref bitarray row col) (the bit (aref pattern col)))) (incf row)) (create-image :width width :height height :plist plist :data bitarray))) @@ -2625,42 +2625,42 @@ ;; GCONTEXT is used for putting the image into the pixmap. ;; If none is supplied, then one is created, used then freed. (declare (type drawable drawable) - (type image image) - (type (or null gcontext) gcontext) - (type (or null card16) width height) - (type (or null card8) depth)) + (type image image) + (type (or null gcontext) gcontext) + (type (or null card16) width height) + (type (or null card8) depth)) (declare (clx-values pixmap)) (let* ((image-width (image-width image)) - (image-height (image-height image)) - (image-depth (image-depth image)) - (width (or width image-width)) - (height (or height image-height)) - (depth (or depth image-depth)) - (pixmap (create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (or gcontext (create-gcontext - :drawable pixmap - :foreground 1 - :background 0)))) + (image-height (image-height image)) + (image-depth (image-depth image)) + (width (or width image-width)) + (height (or height image-height)) + (depth (or depth image-depth)) + (pixmap (create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (or gcontext (create-gcontext + :drawable pixmap + :foreground 1 + :background 0)))) (unless (= depth image-depth) (if (= image-depth 1) - (unless gcontext (xlib::required-arg gcontext)) - (error "Pixmap depth ~d incompatible with image depth ~d" - depth image-depth))) + (unless gcontext (xlib::required-arg gcontext)) + (error "Pixmap depth ~d incompatible with image depth ~d" + depth image-depth))) (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) - gcontext)) + gcontext)) ;; Tile when image-width is less than the pixmap width, or ;; the image-height is less than the pixmap height. ;; ??? Would it be better to create a temporary pixmap and ;; ??? let the server do the tileing? (do ((x image-width (+ x image-width))) - ((>= x width)) + ((>= x width)) (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) (incf image-width image-width)) (do ((y image-height (+ y image-height))) - ((>= y height)) + ((>= y height)) (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) (incf image-height image-height)) (unless gcontext (free-gcontext gc)) diff --git a/src/clx/input.lisp b/src/clx/input.lisp index 3719c5b0f..33807bce8 100644 --- a/src/clx/input.lisp +++ b/src/clx/input.lisp @@ -3,9 +3,9 @@ ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -21,9 +21,9 @@ ;;; ;;; Change history: ;;; -;;; Date Author Description +;;; Date Author Description ;;; ------------------------------------------------------------------------------------- -;;; 12/10/87 LGO Created +;;; 12/10/87 LGO Created (in-package :xlib) @@ -53,28 +53,28 @@ (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) ;; Extensions are handled as follows: -;; DEFINITION: Use DEFINE-EXTENSION +;; DEFINITION: Use DEFINE-EXTENSION ;; -;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. -;; This looks up the code on the display-extension-alist. +;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. +;; This looks up the code on the display-extension-alist. ;; -;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE -;; at LOAD time to define an internal event-code number -;; (stored in the 'event-code property of the event-name) -;; used to index the following vectors: -;; *event-key-vector* Used for getting the event-key -;; *event-macro-vector* Used for getting the event-parameter getting macros +;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE +;; at LOAD time to define an internal event-code number +;; (stored in the 'event-code property of the event-name) +;; used to index the following vectors: +;; *event-key-vector* Used for getting the event-key +;; *event-macro-vector* Used for getting the event-parameter getting macros ;; -;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert -;; a server event-code into an internal event-code used to index the following -;; vectors: -;; *event-handler-vector* Used for getting the event-handler function -;; *event-send-vector* Used for getting the event-sending function +;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert +;; a server event-code into an internal event-code used to index the following +;; vectors: +;; *event-handler-vector* Used for getting the event-handler function +;; *event-send-vector* Used for getting the event-sending function ;; -;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert -;; internal event-codes to external (server) codes. +;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert +;; internal event-codes to external (server) codes. ;; -;; ERRORS: Use DEFINE-ERROR to define new error decodings. +;; ERRORS: Use DEFINE-ERROR to define new error decodings. ;; @@ -92,12 +92,12 @@ ;; To define event handlers, use declare-event. ;; To define error handlers, use declare-error and define-condition. (declare (type stringable name) - (type list events errors)) + (type list events errors)) (let ((name-symbol (kintern name)) ;; Intern name in the keyword package - (event-list (mapcar #'canonicalize-event-name events))) + (event-list (mapcar #'canonicalize-event-name events))) `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) - (delete ',name-symbol *extensions* :key #'car)))))) + (delete ',name-symbol *extensions* :key #'car)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun canonicalize-event-name (event) @@ -121,13 +121,13 @@ (let ((event-code (get name 'event-code))) (declare (type (or null card8) event-code)) (unless event-code - ;; First ensure the name is for a declared extension + ;; First ensure the name is for a declared extension (unless (extension-event-key-p name) - (x-type-error name 'event-key)) - (setq event-code (position nil *event-key-vector* - :start *first-extension-event-code*)) - (setf (svref *event-key-vector* event-code) name) - (setf (get name 'event-code) event-code)) + (x-type-error name 'event-key)) + (setq event-code (position nil *event-key-vector* + :start *first-extension-event-code*)) + (setf (svref *event-key-vector* event-code) name) + (setf (get name 'event-code) event-code)) event-code))) (defun get-internal-event-code (display code) @@ -136,33 +136,33 @@ ;; *event-key-vector* *event-handler-vector* *event-send-vector* ;; Returns NIL when the event-code is for an extension that isn't handled. (declare (type display display) - (type card8 code)) + (type card8 code)) (declare (clx-values (or null card8))) (setq code (logand #x7f code)) (if (< code *first-extension-event-code*) code (let* ((code-offset (- code *first-extension-event-code*)) - (event-extensions (display-event-extensions display)) - (code (if (< code-offset (length event-extensions)) - (aref event-extensions code-offset) - 0))) + (event-extensions (display-event-extensions display)) + (code (if (< code-offset (length event-extensions)) + (aref event-extensions code-offset) + 0))) (declare (type card8 code-offset code)) (when (zerop code) - (x-cerror "Ignore the event" - 'unimplemented-event :event-code code :display display)) + (x-cerror "Ignore the event" + 'unimplemented-event :event-code code :display display)) code))) (defun get-external-event-code (display event) ;; Given an X11 event name, return the event-code (declare (type display display) - (type event-key event)) + (type event-key event)) (declare (clx-values card8)) (let ((code (get-event-code event))) (declare (type (or null card8) code)) (when (>= code *first-extension-event-code*) (setq code (+ *first-extension-event-code* - (or (position code (display-event-extensions display)) - (x-error 'undefined-event :display display :event-name event))))) + (or (position code (display-event-extensions display)) + (x-error 'undefined-event :display display :event-name event))))) code)) (defmacro extension-opcode (display name) @@ -172,41 +172,41 @@ ;; Note: The case of NAME is important. (let ((name-symbol (kintern name))) ;; Intern name in the keyword package `(or (second (assoc ',name-symbol (display-extension-alist ,display))) - (x-error 'absent-extension :name ',name-symbol :display ,display)))) + (x-error 'absent-extension :name ',name-symbol :display ,display)))) (defun initialize-extensions (display) ;; Initialize extensions for DISPLAY (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) - (extension-alist nil)) + (extension-alist nil)) (declare (type vector event-extensions) - (type list extension-alist)) + (type list extension-alist)) (dolist (extension *extensions*) (let ((name (first extension)) - (events (second extension))) - (declare (type keyword name) - (type list events)) - (multiple-value-bind (major-opcode first-event first-error) - (query-extension display name) - (declare (type (or null card8) major-opcode first-event first-error)) - (when (and major-opcode (plusp major-opcode)) - (push (list name major-opcode first-event first-error) - extension-alist) - (when (plusp first-event) ;; When there are extension events - ;; Grow extension vector when needed - (let ((max-event (- (+ first-event (length events)) - *first-extension-event-code*))) - (declare (type card8 max-event)) - (when (>= max-event (length event-extensions)) - (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 - :initial-element 0))) - (declare (type vector new-extensions)) - (replace new-extensions event-extensions) - (setq event-extensions new-extensions)))) - (dolist (event events) - (declare (type symbol event)) - (setf (aref event-extensions (- first-event *first-extension-event-code*)) - (get-event-code event)) - (incf first-event))))))) + (events (second extension))) + (declare (type keyword name) + (type list events)) + (multiple-value-bind (major-opcode first-event first-error) + (query-extension display name) + (declare (type (or null card8) major-opcode first-event first-error)) + (when (and major-opcode (plusp major-opcode)) + (push (list name major-opcode first-event first-error) + extension-alist) + (when (plusp first-event) ;; When there are extension events + ;; Grow extension vector when needed + (let ((max-event (- (+ first-event (length events)) + *first-extension-event-code*))) + (declare (type card8 max-event)) + (when (>= max-event (length event-extensions)) + (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 + :initial-element 0))) + (declare (type vector new-extensions)) + (replace new-extensions event-extensions) + (setq event-extensions new-extensions)))) + (dolist (event events) + (declare (type symbol event)) + (setf (aref event-extensions (- first-event *first-extension-event-code*)) + (get-event-code event)) + (incf first-event))))))) (setf (display-event-extensions display) event-extensions) (setf (display-extension-alist display) extension-alist))) @@ -219,42 +219,42 @@ (defun start-pending-command (display) (declare (type display display)) (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* - pending-command-next pending-command) - (make-pending-command)))) + pending-command-next pending-command) + (make-pending-command)))) (declare (type pending-command pending-command)) (setf (pending-command-reply-buffer pending-command) nil) (setf (pending-command-process pending-command) (current-process)) (setf (pending-command-sequence pending-command) - (ldb (byte 16 0) (1+ (buffer-request-number display)))) + (ldb (byte 16 0) (1+ (buffer-request-number display)))) ;; Add the pending command to the end of the threaded list of pending ;; commands for the display. (with-event-queue-internal (display) (threaded-nconc pending-command (display-pending-commands display) - pending-command-next pending-command)) + pending-command-next pending-command)) pending-command)) (defun stop-pending-command (display pending-command) (declare (type display display) - (type pending-command pending-command)) + (type pending-command pending-command)) (with-event-queue-internal (display) ;; Remove the pending command from the threaded list of pending commands ;; for the display. (threaded-delete pending-command (display-pending-commands display) - pending-command-next pending-command) + pending-command-next pending-command) ;; Deallocate any reply buffers in this pending command (loop (let ((reply-buffer - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-reply-buffer reply-buffer) - (return nil))))) + (threaded-pop (pending-command-reply-buffer pending-command) + reply-next reply-buffer))) + (declare (type (or null reply-buffer) reply-buffer)) + (if reply-buffer + (deallocate-reply-buffer reply-buffer) + (return nil))))) ;; Clear pointers to help the Garbage Collector (setf (pending-command-process pending-command) nil) ;; Deallocate this pending-command (threaded-atomic-push pending-command *pending-command-free-list* - pending-command-next pending-command) + pending-command-next pending-command) nil) ;;; @@ -268,101 +268,101 @@ (let ((index (integer-length (index1- size)))) (declare (type array-index index)) (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) - reply-next reply-buffer) - (make-reply-buffer (index-ash 1 index)))))) + reply-next reply-buffer) + (make-reply-buffer (index-ash 1 index)))))) (defun deallocate-reply-buffer (reply-buffer) (declare (type reply-buffer reply-buffer)) (let ((size (reply-size reply-buffer))) (declare (type array-index size)) (if (index<= size +replysize+) - (deallocate-event reply-buffer) + (deallocate-event reply-buffer) (let ((index (integer-length (index1- size)))) - (declare (type array-index index)) - (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) - reply-next reply-buffer))))) + (declare (type array-index index)) + (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) + reply-next reply-buffer))))) ;;; (defun read-error-input (display sequence reply-buffer token) (declare (type display display) - (type reply-buffer reply-buffer) - (type card16 sequence)) + (type reply-buffer reply-buffer) + (type card16 sequence)) (tagbody start (with-event-queue-internal (display) - (let ((command - ;; Find any pending command with this sequence number. - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (cond ((not (null command)) - ;; Give this reply to the pending command - (threaded-nconc reply-buffer (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))) - ((member :immediately (display-report-asynchronous-errors display)) - ;; No pending command and we should report the error immediately - (go report-error)) - (t - ;; No pending command found, count this as an asynchronous error - (threaded-nconc reply-buffer (display-asynchronous-errors display) - reply-next reply-buffer))))) + (let ((command + ;; Find any pending command with this sequence number. + (threaded-dolist (pending-command (display-pending-commands display) + pending-command-next pending-command) + (when (= (pending-command-sequence pending-command) sequence) + (return pending-command))))) + (declare (type (or null pending-command) command)) + (cond ((not (null command)) + ;; Give this reply to the pending command + (threaded-nconc reply-buffer (pending-command-reply-buffer command) + reply-next reply-buffer) + (process-wakeup (pending-command-process command))) + ((member :immediately (display-report-asynchronous-errors display)) + ;; No pending command and we should report the error immediately + (go report-error)) + (t + ;; No pending command found, count this as an asynchronous error + (threaded-nconc reply-buffer (display-asynchronous-errors display) + reply-next reply-buffer))))) (return-from read-error-input nil) report-error (note-input-complete display token) (apply #'report-error display - (prog1 (make-error display reply-buffer t) - (deallocate-event reply-buffer))))) + (prog1 (make-error display reply-buffer t) + (deallocate-event reply-buffer))))) (defun read-reply-input (display sequence length reply-buffer) (declare (type display display) - (type (or null reply-buffer) reply-buffer) - (type card16 sequence) - (type array-index length)) + (type (or null reply-buffer) reply-buffer) + (type card16 sequence) + (type array-index length)) (unwind-protect (progn - (when (index< +replysize+ length) - (let ((repbuf nil)) - (declare (type (or null reply-buffer) repbuf)) - (unwind-protect - (progn - (setq repbuf (allocate-reply-buffer length)) - (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) - 0 +replysize+) - (deallocate-event (shiftf reply-buffer repbuf nil))) - (when repbuf - (deallocate-reply-buffer repbuf)))) - (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) - (return-from read-reply-input t)) - (setf (reply-data-size reply-buffer) length)) - (with-event-queue-internal (display) - ;; Find any pending command with this sequence number. - (let ((command - (threaded-dolist (pending-command (display-pending-commands display) - pending-command-next pending-command) - (when (= (pending-command-sequence pending-command) sequence) - (return pending-command))))) - (declare (type (or null pending-command) command)) - (when command - ;; Give this reply to the pending command - (threaded-nconc (shiftf reply-buffer nil) - (pending-command-reply-buffer command) - reply-next reply-buffer) - (process-wakeup (pending-command-process command))))) - nil) + (when (index< +replysize+ length) + (let ((repbuf nil)) + (declare (type (or null reply-buffer) repbuf)) + (unwind-protect + (progn + (setq repbuf (allocate-reply-buffer length)) + (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) + 0 +replysize+) + (deallocate-event (shiftf reply-buffer repbuf nil))) + (when repbuf + (deallocate-reply-buffer repbuf)))) + (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) + (return-from read-reply-input t)) + (setf (reply-data-size reply-buffer) length)) + (with-event-queue-internal (display) + ;; Find any pending command with this sequence number. + (let ((command + (threaded-dolist (pending-command (display-pending-commands display) + pending-command-next pending-command) + (when (= (pending-command-sequence pending-command) sequence) + (return pending-command))))) + (declare (type (or null pending-command) command)) + (when command + ;; Give this reply to the pending command + (threaded-nconc (shiftf reply-buffer nil) + (pending-command-reply-buffer command) + reply-next reply-buffer) + (process-wakeup (pending-command-process command))))) + nil) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) (defun read-event-input (display code reply-buffer) (declare (type display display) - (type card8 code) - (type reply-buffer reply-buffer)) + (type card8 code) + (type reply-buffer reply-buffer)) ;; Push the event in the input buffer on the display's event queue (setf (event-code reply-buffer) - (get-internal-event-code display code)) + (get-internal-event-code display code)) (enqueue-event reply-buffer display) nil) @@ -374,219 +374,219 @@ ;; Let the event process get the first chance to do input (let ((process (display-event-process display))) (when (not (null process)) - (process-wakeup process))) + (process-wakeup process))) ;; Then give processes waiting for command responses a chance (unless (display-input-in-progress display) (with-event-queue-internal (display) - (threaded-dolist (command (display-pending-commands display) - pending-command-next pending-command) - (process-wakeup (pending-command-process command))))))) + (threaded-dolist (command (display-pending-commands display) + pending-command-next pending-command) + (process-wakeup (pending-command-process command))))))) (defun read-input (display timeout force-output-p predicate &rest predicate-args) (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (dynamic-extent predicate-args)) + (type (or null number) timeout) + (type generalized-boolean force-output-p) + (dynamic-extent predicate-args)) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg predicate)) (let ((reply-buffer nil) - (token (or (current-process) (cons nil nil)))) + (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect - (tagbody - loop - (when (display-dead display) - (x-error 'closed-display :display display)) - (when (apply predicate predicate-args) - (return-from read-input nil)) - ;; Check and see if we have to force output - (when (and force-output-p - (or (and (not (eq (display-input-in-progress display) token)) - (not (conditional-store - (display-input-in-progress display) nil token))) - (null (buffer-listen display)))) - (go force-output)) - ;; Ensure that only one process is reading input. - (unless (or (eq (display-input-in-progress display) token) - (conditional-store (display-input-in-progress display) nil token)) - (if (eql timeout 0) - (return-from read-input :timeout) - (apply #'process-block "CLX Input Lock" - #'(lambda (display predicate &rest predicate-args) - (declare (type display display) - (dynamic-extent predicate-args) - (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) - (or (apply predicate predicate-args) - (null (display-input-in-progress display)) - (not (null (display-dead display))))) - display predicate predicate-args)) - (go loop)) - ;; Now start gobbling. - (setq reply-buffer (allocate-event)) - (with-buffer-input (reply-buffer :sizes (8 16 32)) - (let ((type 0)) - (declare (type card8 type)) - ;; Wait for input before we disallow aborts. - (unless (eql timeout 0) - (let ((eof-p (buffer-input-wait display timeout))) - (when eof-p (return-from read-input eof-p)))) - (without-aborts - (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ - (if force-output-p 0 timeout)))) - (when eof-p - (when (eq eof-p :timeout) - (if force-output-p - (go force-output) - (return-from read-input :timeout))) - (setf (display-dead display) t) - (return-from read-input eof-p))) - (setf (reply-data-size reply-buffer) +replysize+) - (when (= (the card8 (setq type (read-card8 0))) 1) - ;; Normal replies can be longer than +replysize+, so we - ;; have to handle them while aborts are still disallowed. - (let ((value - (read-reply-input - display (read-card16 2) - (index+ +replysize+ (index* (read-card32 4) 4)) - (shiftf reply-buffer nil)))) - (when value - (return-from read-input value)) - (go loop)))) - (if (zerop type) - (read-error-input - display (read-card16 2) (shiftf reply-buffer nil) token) - (read-event-input - display (read-card8 0) (shiftf reply-buffer nil))))) - (go loop) - force-output - (note-input-complete display token) - (display-force-output display) - (setq force-output-p nil) - (go loop)) + (tagbody + loop + (when (display-dead display) + (x-error 'closed-display :display display)) + (when (apply predicate predicate-args) + (return-from read-input nil)) + ;; Check and see if we have to force output + (when (and force-output-p + (or (and (not (eq (display-input-in-progress display) token)) + (not (conditional-store + (display-input-in-progress display) nil token))) + (null (buffer-listen display)))) + (go force-output)) + ;; Ensure that only one process is reading input. + (unless (or (eq (display-input-in-progress display) token) + (conditional-store (display-input-in-progress display) nil token)) + (if (eql timeout 0) + (return-from read-input :timeout) + (apply #'process-block "CLX Input Lock" + #'(lambda (display predicate &rest predicate-args) + (declare (type display display) + (dynamic-extent predicate-args) + (type function predicate) + #+clx-ansi-common-lisp + (dynamic-extent predicate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg predicate)) + (or (apply predicate predicate-args) + (null (display-input-in-progress display)) + (not (null (display-dead display))))) + display predicate predicate-args)) + (go loop)) + ;; Now start gobbling. + (setq reply-buffer (allocate-event)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (let ((type 0)) + (declare (type card8 type)) + ;; Wait for input before we disallow aborts. + (unless (eql timeout 0) + (let ((eof-p (buffer-input-wait display timeout))) + (when eof-p (return-from read-input eof-p)))) + (without-aborts + (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ + (if force-output-p 0 timeout)))) + (when eof-p + (when (eq eof-p :timeout) + (if force-output-p + (go force-output) + (return-from read-input :timeout))) + (setf (display-dead display) t) + (return-from read-input eof-p))) + (setf (reply-data-size reply-buffer) +replysize+) + (when (= (the card8 (setq type (read-card8 0))) 1) + ;; Normal replies can be longer than +replysize+, so we + ;; have to handle them while aborts are still disallowed. + (let ((value + (read-reply-input + display (read-card16 2) + (index+ +replysize+ (index* (read-card32 4) 4)) + (shiftf reply-buffer nil)))) + (when value + (return-from read-input value)) + (go loop)))) + (if (zerop type) + (read-error-input + display (read-card16 2) (shiftf reply-buffer nil) token) + (read-event-input + display (read-card8 0) (shiftf reply-buffer nil))))) + (go loop) + force-output + (note-input-complete display token) + (display-force-output display) + (setq force-output-p nil) + (go loop)) (when (not (null reply-buffer)) - (deallocate-reply-buffer reply-buffer)) + (deallocate-reply-buffer reply-buffer)) (note-input-complete display token)))) (defun report-asynchronous-errors (display mode) (when (and (display-asynchronous-errors display) - (member mode (display-report-asynchronous-errors display))) + (member mode (display-report-asynchronous-errors display))) (let ((aborted t)) (unwind-protect - (loop - (let ((error - (with-event-queue-internal (display) - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer)))) - (declare (type (or null reply-buffer) error)) - (if error - (apply #'report-error display - (prog1 (make-error display error t) - (deallocate-event error))) - (return (setq aborted nil))))) - ;; If we get aborted out of this, deallocate all outstanding asynchronous - ;; errors. - (when aborted - (with-event-queue-internal (display) - (loop - (let ((reply-buffer - (threaded-pop (display-asynchronous-errors display) - reply-next reply-buffer))) - (declare (type (or null reply-buffer) reply-buffer)) - (if reply-buffer - (deallocate-event reply-buffer) - (return nil)))))))))) + (loop + (let ((error + (with-event-queue-internal (display) + (threaded-pop (display-asynchronous-errors display) + reply-next reply-buffer)))) + (declare (type (or null reply-buffer) error)) + (if error + (apply #'report-error display + (prog1 (make-error display error t) + (deallocate-event error))) + (return (setq aborted nil))))) + ;; If we get aborted out of this, deallocate all outstanding asynchronous + ;; errors. + (when aborted + (with-event-queue-internal (display) + (loop + (let ((reply-buffer + (threaded-pop (display-asynchronous-errors display) + reply-next reply-buffer))) + (declare (type (or null reply-buffer) reply-buffer)) + (if reply-buffer + (deallocate-event reply-buffer) + (return nil)))))))))) (defun wait-for-event (display timeout force-output-p) (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p)) + (type (or null number) timeout) + (type generalized-boolean force-output-p)) (let ((event-process-p (not (eql timeout 0)))) (declare (type generalized-boolean event-process-p)) (unwind-protect - (loop - (when event-process-p - (conditional-store (display-event-process display) nil (current-process))) - (let ((eof (read-input - display timeout force-output-p - #'(lambda (display) - (declare (type display display)) - (or (not (null (display-new-events display))) - (and (display-asynchronous-errors display) - (member :before-event-handling - (display-report-asynchronous-errors display)) - t))) - display))) - (when eof (return eof))) - ;; Report asynchronous errors here if the user wants us to. - (when event-process-p - (report-asynchronous-errors display :before-event-handling)) - (when (not (null (display-new-events display))) - (return nil))) + (loop + (when event-process-p + (conditional-store (display-event-process display) nil (current-process))) + (let ((eof (read-input + display timeout force-output-p + #'(lambda (display) + (declare (type display display)) + (or (not (null (display-new-events display))) + (and (display-asynchronous-errors display) + (member :before-event-handling + (display-report-asynchronous-errors display)) + t))) + display))) + (when eof (return eof))) + ;; Report asynchronous errors here if the user wants us to. + (when event-process-p + (report-asynchronous-errors display :before-event-handling)) + (when (not (null (display-new-events display))) + (return nil))) (when (and event-process-p - (eq (display-event-process display) (current-process))) - (setf (display-event-process display) nil))))) + (eq (display-event-process display) (current-process))) + (setf (display-event-process display) nil))))) (defun read-reply (display pending-command) (declare (type display display) - (type pending-command pending-command)) + (type pending-command pending-command)) (loop (when (read-input display nil nil - #'(lambda (pending-command) - (declare (type pending-command pending-command)) - (not (null (pending-command-reply-buffer pending-command)))) - pending-command) + #'(lambda (pending-command) + (declare (type pending-command pending-command)) + (not (null (pending-command-reply-buffer pending-command)))) + pending-command) (x-error 'closed-display :display display)) (let ((reply-buffer - (with-event-queue-internal (display) - (threaded-pop (pending-command-reply-buffer pending-command) - reply-next reply-buffer)))) + (with-event-queue-internal (display) + (threaded-pop (pending-command-reply-buffer pending-command) + reply-next reply-buffer)))) (declare (type reply-buffer reply-buffer)) ;; Check for error. (with-buffer-input (reply-buffer) - (ecase (read-card8 0) - (0 (apply #'report-error display - (prog1 (make-error display reply-buffer nil) - (deallocate-reply-buffer reply-buffer)))) - (1 (return reply-buffer))))))) + (ecase (read-card8 0) + (0 (apply #'report-error display + (prog1 (make-error display reply-buffer nil) + (deallocate-reply-buffer reply-buffer)))) + (1 (return reply-buffer))))))) ;;; (defun event-listen (display &optional (timeout 0)) (declare (type display display) - (type (or null number) timeout) - (clx-values number-of-events-queued eof-or-timeout)) + (type (or null number) timeout) + (clx-values number-of-events-queued eof-or-timeout)) ;; Returns the number of events queued locally, if any, else nil. Hangs ;; waiting for events, forever if timeout is nil, else for the specified ;; number of seconds. (let* ((current-event-symbol (car (display-current-event-symbol display))) - (current-event (and (boundp current-event-symbol) - (symbol-value current-event-symbol))) - (queue (if current-event - (reply-next (the reply-buffer current-event)) - (display-event-queue-head display)))) + (current-event (and (boundp current-event-symbol) + (symbol-value current-event-symbol))) + (queue (if current-event + (reply-next (the reply-buffer current-event)) + (display-event-queue-head display)))) (declare (type symbol current-event-symbol) - (type (or null reply-buffer) current-event queue)) + (type (or null reply-buffer) current-event queue)) (if queue - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length queue reply-next reply-buffer)) - nil) + (values + (with-event-queue-internal (display :timeout timeout) + (threaded-length queue reply-next reply-buffer)) + nil) (with-event-queue (display :timeout timeout :inline t) - (let ((eof-or-timeout (wait-for-event display timeout nil))) - (if eof-or-timeout - (values nil eof-or-timeout) - (values - (with-event-queue-internal (display :timeout timeout) - (threaded-length (display-new-events display) - reply-next reply-buffer)) - nil))))))) + (let ((eof-or-timeout (wait-for-event display timeout nil))) + (if eof-or-timeout + (values nil eof-or-timeout) + (values + (with-event-queue-internal (display :timeout timeout) + (threaded-length (display-new-events display) + reply-next reply-buffer)) + nil))))))) (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) ;; The event is put at the head of the queue if append-p is nil, else the tail. @@ -594,58 +594,58 @@ ;; declare-event, except that both resource-ids and resource objects are accepted ;; in the event components. (declare (type display display) - (type event-key event-key) - (type generalized-boolean append-p send-event-p) - (dynamic-extent args)) + (type event-key event-key) + (type generalized-boolean append-p send-event-p) + (dynamic-extent args)) (unless (get event-key 'event-code) (x-type-error event-key 'event-key)) (let* ((event (allocate-event)) - (buffer (reply-ibuf8 event)) - (event-code (get event-key 'event-code))) + (buffer (reply-ibuf8 event)) + (event-code (get event-key 'event-code))) (declare (type reply-buffer event) - (type buffer-bytes buffer) - (type (or null card8) event-code)) + (type buffer-bytes buffer) + (type (or null card8) event-code)) (unless event-code (x-type-error event-key 'event-key)) (setf (event-code event) event-code) (with-display (display) (apply (svref *event-send-vector* event-code) display args) (buffer-replace buffer - (display-obuf8 display) - 0 - +replysize+ - (index+ 12 (buffer-boffset display))) + (display-obuf8 display) + 0 + +replysize+ + (index+ 12 (buffer-boffset display))) (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) - (aref buffer 2) 0 - (aref buffer 3) 0)) + (aref buffer 2) 0 + (aref buffer 3) 0)) (with-event-queue (display) (if append-p - (enqueue-event event display) - (with-event-queue-internal (display) - (threaded-requeue event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)))))) + (enqueue-event event display) + (with-event-queue-internal (display) + (threaded-requeue event + (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer)))))) (defun enqueue-event (new-event display) (declare (type reply-buffer new-event) - (type display display)) + (type display display)) ;; Place EVENT at the end of the event queue for DISPLAY (let* ((event-code (event-code new-event)) - (event-key (and (index< event-code (length *event-key-vector*)) - (svref *event-key-vector* event-code)))) + (event-key (and (index< event-code (length *event-key-vector*)) + (svref *event-key-vector* event-code)))) (declare (type array-index event-code) - (type (or null keyword) event-key)) + (type (or null keyword) event-key)) (if (null event-key) - (unwind-protect - (cerror "Ignore this event" "No handler for ~s event" event-key) - (deallocate-event new-event)) + (unwind-protect + (cerror "Ignore this event" "No handler for ~s event" event-key) + (deallocate-event new-event)) (with-event-queue-internal (display) - (threaded-enqueue new-event - (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer) - (unless (display-new-events display) - (setf (display-new-events display) new-event)))))) + (threaded-enqueue new-event + (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer) + (unless (display-new-events display) + (setf (display-new-events display) new-event)))))) (defmacro define-event (name code) @@ -706,96 +706,96 @@ ;; This is used to give all events an EVENT-WINDOW item. ;; See the INPUT file for lots of examples. (declare (type (or keyword list) event-codes) - (type (alist (field-type symbol) (field-names list)) + (type (alist (field-type symbol) (field-names list)) declares)) (when (atom event-codes) (setq event-codes (list event-codes))) (setq event-codes (mapcar #'canonicalize-event-name event-codes)) (let* ((keywords nil) - (name (first event-codes)) - (get-macro (xintern name '-event-get-macro)) - (get-function (xintern name '-event-get)) - (put-function (xintern name '-event-put))) + (name (first event-codes)) + (get-macro (xintern name '-event-get-macro)) + (get-function (xintern name '-event-get)) + (put-function (xintern name '-event-put))) (multiple-value-bind (get-code get-index get-sizes) - (get-put-items - 2 declares nil - #'(lambda (type index item args) - (flet ((event-get (type index item args) - (unless (member type '(pad8 pad16)) - `(,(kintern item) - (,(getify type) ,index ,@args))))) - (if (atom item) - (event-get type index item args) - (mapcan #'(lambda (item) - (event-get type index item args)) - item))))) + (get-put-items + 2 declares nil + #'(lambda (type index item args) + (flet ((event-get (type index item args) + (unless (member type '(pad8 pad16)) + `(,(kintern item) + (,(getify type) ,index ,@args))))) + (if (atom item) + (event-get type index item args) + (mapcan #'(lambda (item) + (event-get type index item args)) + item))))) (declare (ignore get-index)) (multiple-value-bind (put-code put-index put-sizes) - (get-put-items - 2 declares t - #'(lambda (type index item args) - (unless (member type '(pad8 pad16)) - (if (atom item) - (progn - (push item keywords) - `((,(putify type) ,index ,item ,@args))) - (let ((names (mapcar #'(lambda (name) (kintern name)) - item))) - (setq keywords (append item keywords)) - `((,(putify type) ,index - (check-consistency ',names ,@item) ,@args))))))) - (declare (ignore put-index)) - `(within-definition (,name declare-event) - (defun ,get-macro (display event-key variable) - ;; Note: we take pains to macroexpand the get-code here to enable application - ;; code to be compiled without having the CLX macros file loaded. - `(let ((%buffer ,display)) - (declare (ignorable %buffer)) - ,(getf `(:display (the display ,display) - :event-key (the keyword ,event-key) - :event-code (the card8 (logand #x7f (read-card8 0))) - :send-event-p (logbitp 7 (read-card8 0)) - ,@',(mapcar #'(lambda (form) - (clx-macroexpand form env)) - get-code)) - variable))) + (get-put-items + 2 declares t + #'(lambda (type index item args) + (unless (member type '(pad8 pad16)) + (if (atom item) + (progn + (push item keywords) + `((,(putify type) ,index ,item ,@args))) + (let ((names (mapcar #'(lambda (name) (kintern name)) + item))) + (setq keywords (append item keywords)) + `((,(putify type) ,index + (check-consistency ',names ,@item) ,@args))))))) + (declare (ignore put-index)) + `(within-definition (,name declare-event) + (defun ,get-macro (display event-key variable) + ;; Note: we take pains to macroexpand the get-code here to enable application + ;; code to be compiled without having the CLX macros file loaded. + `(let ((%buffer ,display)) + (declare (ignorable %buffer)) + ,(getf `(:display (the display ,display) + :event-key (the keyword ,event-key) + :event-code (the card8 (logand #x7f (read-card8 0))) + :send-event-p (logbitp 7 (read-card8 0)) + ,@',(mapcar #'(lambda (form) + (clx-macroexpand form env)) + get-code)) + variable))) - (defun ,get-function (display event handler) - (declare (type display display) - (type reply-buffer event)) - (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) - (reading-event (event :display display :sizes (8 16 ,@get-sizes)) - (funcall handler - :display display - :event-key (svref *event-key-vector* (event-code event)) - :event-code (logand #x7f (card8-get 0)) - :send-event-p (logbitp 7 (card8-get 0)) - ,@get-code))) + (defun ,get-function (display event handler) + (declare (type display display) + (type reply-buffer event)) + (declare (type function handler) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg handler)) + (reading-event (event :display display :sizes (8 16 ,@get-sizes)) + (funcall handler + :display display + :event-key (svref *event-key-vector* (event-code event)) + :event-code (logand #x7f (card8-get 0)) + :send-event-p (logbitp 7 (card8-get 0)) + ,@get-code))) - (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) - &allow-other-keys) - (declare (type display display)) - ,(when (member 'sequence keywords) - `(unless sequence (setq sequence (display-request-number display)))) - (with-buffer-output (display :sizes ,put-sizes - :index (index+ (buffer-boffset display) 12)) - ,@put-code)) + (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) + &allow-other-keys) + (declare (type display display)) + ,(when (member 'sequence keywords) + `(unless sequence (setq sequence (display-request-number display)))) + (with-buffer-output (display :sizes ,put-sizes + :index (index+ (buffer-boffset display) 12)) + ,@put-code)) - ,@(mapcar #'(lambda (name) - (allocate-extension-event-code name) - `(let ((event-code (or (get ',name 'event-code) - (allocate-extension-event-code ',name)))) - (setf (svref *event-macro-vector* event-code) - (function ,get-macro)) - (setf (svref *event-handler-vector* event-code) - (function ,get-function)) - (setf (svref *event-send-vector* event-code) - (function ,put-function)))) - event-codes) - ',name))))) + ,@(mapcar #'(lambda (name) + (allocate-extension-event-code name) + `(let ((event-code (or (get ',name 'event-code) + (allocate-extension-event-code ',name)))) + (setf (svref *event-macro-vector* event-code) + (function ,get-macro)) + (setf (svref *event-handler-vector* event-code) + (function ,get-function)) + (setf (svref *event-send-vector* event-code) + (function ,put-function)))) + event-codes) + ',name))))) (defun check-consistency (names &rest args) ;; Ensure all args are nil or have the same value. @@ -803,10 +803,10 @@ (let ((value (car args))) (dolist (arg (cdr args)) (if value - (when (and arg (not (eq arg value))) - (x-error 'inconsistent-parameters - :parameters (mapcan #'list names args))) - (setq value arg))) + (when (and arg (not (eq arg value))) + (x-error 'inconsistent-parameters + :parameters (mapcan #'list names args))) + (setq value arg))) value)) (declare-event (:key-press :key-release :button-press :button-release) @@ -846,7 +846,7 @@ (declare-event (:focus-in :focus-out) ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual - :pointer :pointer-root :none)) + :pointer :pointer-root :none)) kind) (card16 sequence) (window (window event-window)) @@ -1003,85 +1003,85 @@ (defun event-loop-setup (display) (declare (type display display) - (clx-values progv-vars progv-vals - current-event-symbol current-event-discarded-p-symbol)) + (clx-values progv-vars progv-vals + current-event-symbol current-event-discarded-p-symbol)) (let* ((progv-vars (display-current-event-symbol display)) - (current-event-symbol (first progv-vars)) - (current-event-discarded-p-symbol (second progv-vars))) + (current-event-symbol (first progv-vars)) + (current-event-discarded-p-symbol (second progv-vars))) (declare (type list progv-vars) - (type symbol current-event-symbol current-event-discarded-p-symbol)) + (type symbol current-event-symbol current-event-discarded-p-symbol)) (values progv-vars (list (if (boundp current-event-symbol) - ;; The current event is already bound, so bind it to the next - ;; event. - (let ((event (symbol-value current-event-symbol))) - (declare (type (or null reply-buffer) event)) - (and event (reply-next (the reply-buffer event)))) - ;; The current event isn't bound, so bind it to the head of the - ;; event queue. - (display-event-queue-head display)) - nil) + ;; The current event is already bound, so bind it to the next + ;; event. + (let ((event (symbol-value current-event-symbol))) + (declare (type (or null reply-buffer) event)) + (and event (reply-next (the reply-buffer event)))) + ;; The current event isn't bound, so bind it to the head of the + ;; event queue. + (display-event-queue-head display)) + nil) current-event-symbol current-event-discarded-p-symbol))) (defun event-loop-step-before (display timeout force-output-p current-event-symbol) (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean force-output-p) - (type symbol current-event-symbol) - (clx-values event eof-or-timeout)) + (type (or null number) timeout) + (type generalized-boolean force-output-p) + (type symbol current-event-symbol) + (clx-values event eof-or-timeout)) (unless (symbol-value current-event-symbol) (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) (when eof-or-timeout - (return-from event-loop-step-before (values nil eof-or-timeout)))) + (return-from event-loop-step-before (values nil eof-or-timeout)))) (setf (symbol-value current-event-symbol) (display-new-events display))) (let ((event (symbol-value current-event-symbol))) (declare (type reply-buffer event)) (with-event-queue-internal (display) (when (eq event (display-new-events display)) - (setf (display-new-events display) (reply-next event)))) + (setf (display-new-events display) (reply-next event)))) (values event nil))) (defun dequeue-event (display event) (declare (type display display) - (type reply-buffer event) - (clx-values next)) + (type reply-buffer event) + (clx-values next)) ;; Remove the current event from the event queue (with-event-queue-internal (display) (let ((next (reply-next event)) - (head (display-event-queue-head display))) + (head (display-event-queue-head display))) (declare (type (or null reply-buffer) next head)) (when (eq event (display-new-events display)) - (setf (display-new-events display) next)) + (setf (display-new-events display) next)) (cond ((eq event head) - (threaded-dequeue (display-event-queue-head display) - (display-event-queue-tail display) - reply-next reply-buffer)) - ((null head) - (setq next nil)) - (t - (do* ((previous head current) - (current (reply-next previous) (reply-next previous))) - ((or (null current) (eq event current)) - (when (eq event current) - (when (eq current (display-event-queue-tail display)) - (setf (display-event-queue-tail display) previous)) - (setf (reply-next previous) next))) - (declare (type reply-buffer previous) - (type (or null reply-buffer) current))))) + (threaded-dequeue (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer)) + ((null head) + (setq next nil)) + (t + (do* ((previous head current) + (current (reply-next previous) (reply-next previous))) + ((or (null current) (eq event current)) + (when (eq event current) + (when (eq current (display-event-queue-tail display)) + (setf (display-event-queue-tail display) previous)) + (setf (reply-next previous) next))) + (declare (type reply-buffer previous) + (type (or null reply-buffer) current))))) next))) (defun event-loop-step-after (display event discard-p current-event-symbol current-event-discarded-p-symbol - &optional aborted) + &optional aborted) (declare (type display display) - (type reply-buffer event) - (type generalized-boolean discard-p aborted) - (type symbol current-event-symbol current-event-discarded-p-symbol)) + (type reply-buffer event) + (type generalized-boolean discard-p aborted) + (type symbol current-event-symbol current-event-discarded-p-symbol)) (when (and discard-p - (not aborted) - (not (symbol-value current-event-discarded-p-symbol))) + (not aborted) + (not (symbol-value current-event-discarded-p-symbol))) (discard-current-event display)) (let ((next (reply-next event))) (declare (type (or null reply-buffer) next)) @@ -1095,37 +1095,37 @@ ;; Bind EVENT to the events for DISPLAY. ;; This is the "GUTS" of process-event and event-case. `(let ((.display. ,display) - (.timeout. ,timeout) - (.force-output-p. ,force-output-p) - (.discard-p. ,discard-p)) + (.timeout. ,timeout) + (.force-output-p. ,force-output-p) + (.discard-p. ,discard-p)) (declare (type display .display.) - (type (or null number) .timeout.) - (type generalized-boolean .force-output-p. .discard-p.)) + (type (or null number) .timeout.) + (type generalized-boolean .force-output-p. .discard-p.)) (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) (multiple-value-bind (.progv-vars. .progv-vals. - .current-event-symbol. .current-event-discarded-p-symbol.) - (event-loop-setup .display.) - (declare (type list .progv-vars. .progv-vals.) - (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) - (progv .progv-vars. .progv-vals. - (loop - (multiple-value-bind (.event. .eof-or-timeout.) - (event-loop-step-before - .display. .timeout. .force-output-p. - .current-event-symbol.) - (declare (type (or null reply-buffer) .event.)) - (when (null .event.) (return (values nil .eof-or-timeout.))) - (let ((.aborted. t)) - (unwind-protect - (progn - (let ((,event .event.)) - (declare (type reply-buffer ,event)) - ,@body) - (setq .aborted. nil)) - (event-loop-step-after - .display. .event. .discard-p. - .current-event-symbol. .current-event-discarded-p-symbol. - .aborted.)))))))))) + .current-event-symbol. .current-event-discarded-p-symbol.) + (event-loop-setup .display.) + (declare (type list .progv-vars. .progv-vals.) + (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) + (progv .progv-vars. .progv-vals. + (loop + (multiple-value-bind (.event. .eof-or-timeout.) + (event-loop-step-before + .display. .timeout. .force-output-p. + .current-event-symbol.) + (declare (type (or null reply-buffer) .event.)) + (when (null .event.) (return (values nil .eof-or-timeout.))) + (let ((.aborted. t)) + (unwind-protect + (progn + (let ((,event .event.)) + (declare (type reply-buffer ,event)) + ,@body) + (setq .aborted. nil)) + (event-loop-step-after + .display. .event. .discard-p. + .current-event-symbol. .current-event-discarded-p-symbol. + .aborted.)))))))))) (defun discard-current-event (display) ;; Discard the current event for DISPLAY. @@ -1135,21 +1135,21 @@ ;; inside even-case, event-cond or process-event when :peek-p is T and ;; :discard-p is NIL. (declare (type display display) - (clx-values generalized-boolean)) + (clx-values generalized-boolean)) (let* ((symbols (display-current-event-symbol display)) - (event - (let ((current-event-symbol (first symbols))) - (declare (type symbol current-event-symbol)) - (when (boundp current-event-symbol) - (symbol-value current-event-symbol))))) + (event + (let ((current-event-symbol (first symbols))) + (declare (type symbol current-event-symbol)) + (when (boundp current-event-symbol) + (symbol-value current-event-symbol))))) (declare (type list symbols) - (type (or null reply-buffer) event)) + (type (or null reply-buffer) event)) (unless (null event) ;; Set the discarded-p flag (let ((current-event-discarded-p-symbol (second symbols))) - (declare (type symbol current-event-discarded-p-symbol)) - (when (boundp current-event-discarded-p-symbol) - (setf (symbol-value current-event-discarded-p-symbol) t))) + (declare (type symbol current-event-discarded-p-symbol)) + (when (boundp current-event-discarded-p-symbol) + (setf (symbol-value current-event-discarded-p-symbol) t))) ;; Return whether the event queue is empty (not (null (reply-next (the reply-buffer event))))))) @@ -1174,57 +1174,57 @@ ;; from the queue (it is left in place), NIL means the event is removed. (declare (type display display) - (type (or null number) timeout) - (type generalized-boolean peek-p discard-p force-output-p)) + (type (or null number) timeout) + (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) + #+clx-ansi-common-lisp + (dynamic-extent handler) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera handler)) (event-loop (display event timeout force-output-p discard-p) (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT - (event-decoder (and (index< event-code (length *event-handler-vector*)) - (svref *event-handler-vector* event-code)))) + (event-decoder (and (index< event-code (length *event-handler-vector*)) + (svref *event-handler-vector* event-code)))) (declare (type array-index event-code) - (type (or null function) event-decoder)) + (type (or null function) event-decoder)) (if event-decoder - (let ((event-handler (if (functionp handler) - handler - (and (type? handler 'sequence) - (< event-code (length handler)) - (elt handler event-code))))) - (if event-handler - (let ((result (funcall event-decoder display event event-handler))) - (when result - (unless peek-p - (discard-current-event display)) - (return result))) - (cerror "Ignore this event" - "No handler for ~s event" - (svref *event-key-vector* event-code)))) - (cerror "Ignore this event" - "Server Error: event with unknown event code ~d received." - event-code))))) + (let ((event-handler (if (functionp handler) + handler + (and (type? handler 'sequence) + (< event-code (length handler)) + (elt handler event-code))))) + (if event-handler + (let ((result (funcall event-decoder display event event-handler))) + (when result + (unless peek-p + (discard-current-event display)) + (return result))) + (cerror "Ignore this event" + "No handler for ~s event" + (svref *event-key-vector* event-code)))) + (cerror "Ignore this event" + "Server Error: event with unknown event code ~d received." + event-code))))) (defun make-event-handlers (&key (type 'array) default) - (declare (type t type) ;Sequence type specifier - (type (or null function) default) - (clx-values sequence)) ;Default handler for initial content + (declare (type t type) ;Sequence type specifier + (type (or null function) default) + (clx-values sequence)) ;Default handler for initial content ;; Makes a handler sequence suitable for process-event (make-sequence type +max-events+ :initial-element default)) (defun event-handler (handlers event-key) (declare (type sequence handlers) - (type event-key event-key) - (clx-values function)) + (type event-key event-key) + (clx-values function)) ;; Accessor for a handler sequence (elt handlers (position event-key *event-key-vector* :test #'eq))) (defun set-event-handler (handlers event-key handler) (declare (type sequence handlers) - (type event-key event-key) - (type function handler) - (clx-values handler)) + (type event-key event-key) + (type function handler) + (clx-values handler)) (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) (defsetf event-handler set-event-handler) @@ -1252,38 +1252,38 @@ ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is ;; equivalent to having one that returns nil. (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) - (event-or-events ((&rest args) |...|) &body body) |...|)) + (event-or-events ((&rest args) |...|) &body body) |...|)) ;; Event-case is just event-cond with the whole body in the test-form `(event-cond ,args - ,@(mapcar - #'(lambda (clause) - `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) - clauses))) + ,@(mapcar + #'(lambda (clause) + `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) + clauses))) ;; ;; EVENT-COND ;; (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) - &body clauses) + &body clauses) ;; The clauses of event-cond are of the form: ;; (event-or-events binding-list test-form . body-forms) ;; - ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they - ;; need not be typed as keywords) or the symbol t - ;; or otherwise (but only in the last clause). If - ;; no t/otherwise clause appears, it is equivalent - ;; to having one that returns nil. The keys are - ;; not evaluated, and it is an error for the same - ;; key to appear in more than one clause. + ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they + ;; need not be typed as keywords) or the symbol t + ;; or otherwise (but only in the last clause). If + ;; no t/otherwise clause appears, it is equivalent + ;; to having one that returns nil. The keys are + ;; not evaluated, and it is an error for the same + ;; key to appear in more than one clause. ;; - ;; BINDING-LIST The list of event components of interest. - ;; corresponding values (if any) are bound to - ;; variables with these names (i.e., the binding-list - ;; has variable names, not keywords, the keywords are - ;; derived from the variable names). An arg can also - ;; be a (keyword var) form, as for keyword args in a - ;; lambda list. + ;; BINDING-LIST The list of event components of interest. + ;; corresponding values (if any) are bound to + ;; variables with these names (i.e., the binding-list + ;; has variable names, not keywords, the keywords are + ;; derived from the variable names). An arg can also + ;; be a (keyword var) form, as for keyword args in a + ;; lambda list. ;; ;; The matching TEST-FORM for each queued event is executed until a ;; clause's test-form returns non-nil. Then the BODY-FORMS are @@ -1293,28 +1293,28 @@ ;; single value. ;; ;; Options: - ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no - ;; input is pending. + ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no + ;; input is pending. ;; - ;; PEEK-P When true, then the event is not removed from the queue. + ;; PEEK-P When true, then the event is not removed from the queue. ;; - ;; DISCARD-P When true, then events for which the clause returns nil - ;; are removed from the queue, otherwise they are left in place. + ;; DISCARD-P When true, then events for which the clause returns nil + ;; are removed from the queue, otherwise they are left in place. ;; - ;; TIMEOUT If NIL, hang until non-nil is generated for some event's - ;; test-form. Otherwise return NIL after TIMEOUT seconds have - ;; elapsed. + ;; TIMEOUT If NIL, hang until non-nil is generated for some event's + ;; test-form. Otherwise return NIL after TIMEOUT seconds have + ;; elapsed. ;; (declare (arglist (display &key timeout peek-p discard-p force-output-p) - (event-or-events (&rest args) test-form &body body) |...|)) + (event-or-events (&rest args) test-form &body body) |...|)) (let ((event (gensym)) - (disp (gensym)) - (peek (gensym))) + (disp (gensym)) + (peek (gensym))) `(let ((,disp ,display) - (,peek ,peek-p)) + (,peek ,peek-p)) (declare (type display ,disp)) (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) - (event-dispatch (,disp ,event ,peek) ,@clauses))))) + (event-dispatch (,disp ,event ,peek) ,@clauses))))) (defun get-event-code (event) ;; Returns the event code given an event-key @@ -1326,8 +1326,8 @@ (defun universal-event-get-macro (display event-key variable) (getf `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code - (the card8 (logand 127 (read-card8 0))) :send-event-p - (logbitp 7 (read-card8 0))) + (the card8 (logand 127 (read-card8 0))) :send-event-p + (logbitp 7 (read-card8 0))) variable)) (defmacro event-dispatch ((display event peek-p) &body clauses) @@ -1335,122 +1335,122 @@ ;; CLAUSES are of the form: ;; (event-or-events binding-list test-form . body-forms) (let ((event-key (gensym)) - (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) + (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) `(reading-event (,event) (let ((,event-key (svref *event-key-vector* (event-code ,event)))) - (case ,event-key - ,@(mapcar - #'(lambda (clause) ; Translate event-cond clause to case clause - (let* ((events (first clause)) - (arglist (second clause)) - (test-form (third clause)) - (body-forms (cdddr clause))) - (flet ((event-clause (display peek-p first-form rest-of-forms) - (if rest-of-forms - `(when ,first-form - (unless ,peek-p (discard-current-event ,display)) - (return (progn ,@rest-of-forms))) - ;; No body forms, return the result of the test form - (let ((result (gensym))) - `(let ((,result ,first-form)) - (when ,result - (unless ,peek-p (discard-current-event ,display)) - (return ,result))))))) + (case ,event-key + ,@(mapcar + #'(lambda (clause) ; Translate event-cond clause to case clause + (let* ((events (first clause)) + (arglist (second clause)) + (test-form (third clause)) + (body-forms (cdddr clause))) + (flet ((event-clause (display peek-p first-form rest-of-forms) + (if rest-of-forms + `(when ,first-form + (unless ,peek-p (discard-current-event ,display)) + (return (progn ,@rest-of-forms))) + ;; No body forms, return the result of the test form + (let ((result (gensym))) + `(let ((,result ,first-form)) + (when ,result + (unless ,peek-p (discard-current-event ,display)) + (return ,result))))))) - (if (member events '(otherwise t)) - ;; code for OTHERWISE clause. - ;; Find all events NOT used by other clauses - (let ((keys (do ((i 0 (1+ i)) - (key nil) - (result nil)) - ((>= i +max-events+) result) - (setq key (svref *event-key-vector* i)) - (when (and key (zerop (aref all-events i))) - (push key result))))) - `(otherwise - (binding-event-values - (,display ,event-key ,(or keys :universal) ,@arglist) - ,(event-clause display peek-p test-form body-forms)))) + (if (member events '(otherwise t)) + ;; code for OTHERWISE clause. + ;; Find all events NOT used by other clauses + (let ((keys (do ((i 0 (1+ i)) + (key nil) + (result nil)) + ((>= i +max-events+) result) + (setq key (svref *event-key-vector* i)) + (when (and key (zerop (aref all-events i))) + (push key result))))) + `(otherwise + (binding-event-values + (,display ,event-key ,(or keys :universal) ,@arglist) + ,(event-clause display peek-p test-form body-forms)))) - ;; Code for normal clauses - (let (true-events) ;; canonicalize event-names - (if (consp events) - (progn - (setq true-events (mapcar #'canonicalize-event-name events)) - (dolist (event true-events) - (setf (aref all-events (get-event-code event)) 1))) - (setf true-events (canonicalize-event-name events) - (aref all-events (get-event-code true-events)) 1)) - `(,true-events - (binding-event-values - (,display ,event-key ,true-events ,@arglist) - ,(event-clause display peek-p test-form body-forms)))))))) - clauses)))))) + ;; Code for normal clauses + (let (true-events) ;; canonicalize event-names + (if (consp events) + (progn + (setq true-events (mapcar #'canonicalize-event-name events)) + (dolist (event true-events) + (setf (aref all-events (get-event-code event)) 1))) + (setf true-events (canonicalize-event-name events) + (aref all-events (get-event-code true-events)) 1)) + `(,true-events + (binding-event-values + (,display ,event-key ,true-events ,@arglist) + ,(event-clause display peek-p test-form body-forms)))))))) + clauses)))))) (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) ;; Execute BODY with the variables in VALUE-LIST bound to components of the ;; EVENT-KEYS events. (unless (consp event-keys) (setq event-keys (list event-keys))) (flet ((var-key (var) (kintern (if (consp var) (first var) var))) - (var-symbol (var) (if (consp var) (second var) var))) + (var-symbol (var) (if (consp var) (second var) var))) ;; VARS is an alist of: ;; (component-key ((event-key event-key ...) . extraction-code) - ;; ((event-key event-key ...) . extraction-code) ...) + ;; ((event-key event-key ...) . extraction-code) ...) ;; There should probably be accessor macros for this, instead of things like cdadr. (let ((vars (mapcar #'list value-list)) - (multiple-p nil)) + (multiple-p nil)) ;; Fill in the VARS alist with event-keys and extraction-code (do ((keys event-keys (cdr keys)) - (temp nil)) - ((endp keys)) - (let* ((key (car keys)) - (binder (case key - (:universal #'universal-event-get-macro) - (otherwise (svref *event-macro-vector* (get-event-code key)))))) - (dolist (var vars) - (let ((code (funcall binder display event-key (var-key (car var))))) - (unless code (warn "~a isn't a component of the ~s event" - (var-key (car var)) key)) - (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) - (push key (caar temp)) - (push `((,key) . ,code) (cdr var))))))) + (temp nil)) + ((endp keys)) + (let* ((key (car keys)) + (binder (case key + (:universal #'universal-event-get-macro) + (otherwise (svref *event-macro-vector* (get-event-code key)))))) + (dolist (var vars) + (let ((code (funcall binder display event-key (var-key (car var))))) + (unless code (warn "~a isn't a component of the ~s event" + (var-key (car var)) key)) + (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) + (push key (caar temp)) + (push `((,key) . ,code) (cdr var))))))) ;; Bind all the values `(let ,(mapcar #'(lambda (var) - (if (cddr var) ;; if more than one binding form - (progn (setq multiple-p t) - (var-symbol (car var))) - (list (var-symbol (car var)) (cdadr var)))) - vars) - ;; When some values come from different places, generate code to set them - ,(when multiple-p - `(case ,event-key - ,@(do ((keys event-keys (cdr keys)) - (clauses nil) ;; alist of (event-keys bindings) - (clause nil nil) - (temp)) - ((endp keys) - (dolist (clause clauses) - (unless (cdar clause) ;; Atomize single element lists - (setf (car clause) (caar clause)))) - clauses) - ;; Gather up all the bindings associated with (car keys) - (dolist (var vars) - (when (cddr var) ;; when more than one binding form - (dolist (events (cdr var)) - (when (member (car keys) (car events)) - ;; Optimize for event-window being the same as some other binding - (if (setq temp (member (cdr events) clause - :key #'caddr - :test #'equal)) - (setq clause - (nconc clause `((setq ,(car var) ,(second (car temp)))))) - (push `(setq ,(car var) ,(cdr events)) clause)))))) - ;; Merge bindings for (car keys) with other bindings - (when clause - (if (setq temp (member clause clauses :key #'cdr :test #'equal)) - (push (car keys) (caar temp)) - (push `((,(car keys)) . ,clause) clauses)))))) - ,@body)))) + (if (cddr var) ;; if more than one binding form + (progn (setq multiple-p t) + (var-symbol (car var))) + (list (var-symbol (car var)) (cdadr var)))) + vars) + ;; When some values come from different places, generate code to set them + ,(when multiple-p + `(case ,event-key + ,@(do ((keys event-keys (cdr keys)) + (clauses nil) ;; alist of (event-keys bindings) + (clause nil nil) + (temp)) + ((endp keys) + (dolist (clause clauses) + (unless (cdar clause) ;; Atomize single element lists + (setf (car clause) (caar clause)))) + clauses) + ;; Gather up all the bindings associated with (car keys) + (dolist (var vars) + (when (cddr var) ;; when more than one binding form + (dolist (events (cdr var)) + (when (member (car keys) (car events)) + ;; Optimize for event-window being the same as some other binding + (if (setq temp (member (cdr events) clause + :key #'caddr + :test #'equal)) + (setq clause + (nconc clause `((setq ,(car var) ,(second (car temp)))))) + (push `(setq ,(car var) ,(cdr events)) clause)))))) + ;; Merge bindings for (car keys) with other bindings + (when clause + (if (setq temp (member clause clauses :key #'cdr :test #'equal)) + (push (car keys) (caar temp)) + (push `((,(car keys)) . ,clause) clauses)))))) + ,@body)))) ;;;----------------------------------------------------------------------------- @@ -1461,43 +1461,43 @@ (defparameter *xerror-vector* '#(unknown-error - request-error ; 1 bad request code - value-error ; 2 integer parameter out of range - window-error ; 3 parameter not a Window - pixmap-error ; 4 parameter not a Pixmap - atom-error ; 5 parameter not an Atom - cursor-error ; 6 parameter not a Cursor - font-error ; 7 parameter not a Font - match-error ; 8 parameter mismatch - drawable-error ; 9 parameter not a Pixmap or Window - access-error ; 10 attempt to access private resource" - alloc-error ; 11 insufficient resources - colormap-error ; 12 no such colormap - gcontext-error ; 13 parameter not a GContext - id-choice-error ; 14 invalid resource ID for this connection - name-error ; 15 font or color name does not exist - length-error ; 16 request length incorrect; - ; internal Xlib error - implementation-error ; 17 server is defective + request-error ; 1 bad request code + value-error ; 2 integer parameter out of range + window-error ; 3 parameter not a Window + pixmap-error ; 4 parameter not a Pixmap + atom-error ; 5 parameter not an Atom + cursor-error ; 6 parameter not a Cursor + font-error ; 7 parameter not a Font + match-error ; 8 parameter mismatch + drawable-error ; 9 parameter not a Pixmap or Window + access-error ; 10 attempt to access private resource" + alloc-error ; 11 insufficient resources + colormap-error ; 12 no such colormap + gcontext-error ; 13 parameter not a GContext + id-choice-error ; 14 invalid resource ID for this connection + name-error ; 15 font or color name does not exist + length-error ; 16 request length incorrect; + ; internal Xlib error + implementation-error ; 17 server is defective )) ) (defun make-error (display event asynchronous) (declare (type display display) - (type reply-buffer event) - (type generalized-boolean asynchronous)) + (type reply-buffer event) + (type generalized-boolean asynchronous)) (reading-event (event) (let* ((error-code (read-card8 1)) - (error-key (get-error-key display error-code)) - (error-decode-function (get error-key 'error-decode-function)) - (params (funcall error-decode-function display event))) + (error-key (get-error-key display error-code)) + (error-decode-function (get error-key 'error-decode-function)) + (params (funcall error-decode-function display event))) (list* error-code error-key - :asynchronous asynchronous :current-sequence (display-request-number display) - params)))) + :asynchronous asynchronous :current-sequence (display-request-number display) + params)))) (defun report-error (display error-code error-key &rest params) (declare (type display display) - (dynamic-extent params)) + (dynamic-extent params)) ;; All errors (synchronous and asynchronous) are processed by calling ;; an error handler in the display. The handler is called with the display ;; as the first argument and the error-key as its second argument. If handler is @@ -1520,10 +1520,10 @@ ;; For :value errors, another pair is: ;; :value integer (let* ((handler (display-error-handler display)) - (handler-function - (if (type? handler 'sequence) - (elt handler error-code) - handler))) + (handler-function + (if (type? handler 'sequence) + (elt handler error-code) + handler))) (apply handler-function display error-key params))) (defun request-name (code &optional display) @@ -1531,7 +1531,7 @@ (svref *request-names* code) (dolist (extension (and display (display-extension-alist display)) "unknown") (when (= code (second extension)) - (return (first extension)))))) + (return (first extension)))))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) @@ -1546,15 +1546,15 @@ (defun report-request-error (condition stream) (let ((error-key (request-error-error-key condition)) - (asynchronous (request-error-asynchronous condition)) - (major (request-error-major condition)) - (minor (request-error-minor condition)) - (sequence (request-error-sequence condition)) - (current-sequence (request-error-current-sequence condition))) + (asynchronous (request-error-asynchronous condition)) + (major (request-error-major condition)) + (minor (request-error-minor condition)) + (sequence (request-error-sequence condition)) + (current-sequence (request-error-current-sequence condition))) (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" - asynchronous error-key (= sequence current-sequence) - sequence current-sequence major minor - (request-name major (request-error-display condition))))) + asynchronous error-key (= sequence current-sequence) + sequence current-sequence major minor + (request-name major (request-error-display condition))))) ;; Since the :report arg is evaluated as (function report-request-error) the ;; define-condition must come after the function definition. @@ -1635,16 +1635,16 @@ (:report (lambda (condition stream) (format stream "~s isn't a ~a" - (type-error-datum condition) - (or (x-type-error-type-string condition) - (type-error-expected-type condition)))))) + (type-error-datum condition) + (or (x-type-error-type-string condition) + (type-error-expected-type condition)))))) (define-condition closed-display (x-error) ((display :reader closed-display-display :initarg :display)) (:report (lambda (condition stream) (format stream "Attempt to use closed display ~s" - (closed-display-display condition))))) + (closed-display-display condition))))) (define-condition lookup-error (x-error) ((id :reader lookup-error-id :initarg :id) @@ -1654,10 +1654,10 @@ (:report (lambda (condition stream) (format stream "ID ~d from display ~s should have been a ~s, but was ~s" - (lookup-error-id condition) - (lookup-error-display condition) - (lookup-error-type condition) - (lookup-error-object condition))))) + (lookup-error-id condition) + (lookup-error-display condition) + (lookup-error-type condition) + (lookup-error-object condition))))) (define-condition connection-failure (x-error) ((major-version :reader connection-failure-major-version :initarg :major-version) @@ -1668,11 +1668,11 @@ (:report (lambda (condition stream) (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" - (connection-failure-major-version condition) - (connection-failure-minor-version condition) - (connection-failure-host condition) - (connection-failure-display condition) - (connection-failure-reason condition))))) + (connection-failure-major-version condition) + (connection-failure-minor-version condition) + (connection-failure-host condition) + (connection-failure-display condition) + (connection-failure-reason condition))))) (define-condition reply-length-error (x-error) ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) @@ -1681,9 +1681,9 @@ (:report (lambda (condition stream) (format stream "Reply length was ~d when ~d words were expected for display ~s" - (reply-length-error-reply-length condition) - (reply-length-error-expected-length condition) - (reply-length-error-display condition))))) + (reply-length-error-reply-length condition) + (reply-length-error-expected-length condition) + (reply-length-error-display condition))))) (define-condition reply-timeout (x-error) ((timeout :reader reply-timeout-timeout :initarg :timeout) @@ -1691,8 +1691,8 @@ (:report (lambda (condition stream) (format stream "Timeout after waiting ~d seconds for a reply for display ~s" - (reply-timeout-timeout condition) - (reply-timeout-display condition))))) + (reply-timeout-timeout condition) + (reply-timeout-display condition))))) (define-condition sequence-error (x-error) ((display :reader sequence-error-display :initarg :display) @@ -1701,9 +1701,9 @@ (:report (lambda (condition stream) (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" - (sequence-error-display condition) - (sequence-error-req-sequence condition) - (sequence-error-msg-sequence condition))))) + (sequence-error-display condition) + (sequence-error-req-sequence condition) + (sequence-error-msg-sequence condition))))) (define-condition unexpected-reply (x-error) ((display :reader unexpected-reply-display :initarg :display) @@ -1713,21 +1713,21 @@ (:report (lambda (condition stream) (format stream "Display ~s received a server reply when none was expected.~@ - Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." - (unexpected-reply-display condition) - (unexpected-reply-req-sequence condition) - (unexpected-reply-msg-sequence condition) - (unexpected-reply-length condition))))) + Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." + (unexpected-reply-display condition) + (unexpected-reply-req-sequence condition) + (unexpected-reply-msg-sequence condition) + (unexpected-reply-length condition))))) (define-condition missing-parameter (x-error) ((parameter :reader missing-parameter-parameter :initarg :parameter)) (:report (lambda (condition stream) (let ((parm (missing-parameter-parameter condition))) - (if (consp parm) - (format stream "One or more of the required parameters ~a is missing." - parm) - (format stream "Required parameter ~a is missing or null." parm)))))) + (if (consp parm) + (format stream "One or more of the required parameters ~a is missing." + parm) + (format stream "Required parameter ~a is missing or null." parm)))))) ;; This can be signalled anywhere a pseudo font access fails. (define-condition invalid-font (x-error) @@ -1741,7 +1741,7 @@ (:report (lambda (condition stream) (format stream "Device busy for display ~s" - (device-busy-display condition))))) + (device-busy-display condition))))) (define-condition unimplemented-event (x-error) ((display :reader unimplemented-event-display :initarg :display) @@ -1749,8 +1749,8 @@ (:report (lambda (condition stream) (format stream "Event code ~d not implemented for display ~s" - (unimplemented-event-event-code condition) - (unimplemented-event-display condition))))) + (unimplemented-event-event-code condition) + (unimplemented-event-display condition))))) (define-condition undefined-event (x-error) ((display :reader undefined-event-display :initarg :display) @@ -1758,8 +1758,8 @@ (:report (lambda (condition stream) (format stream "Event code ~d undefined for display ~s" - (undefined-event-event-name condition) - (undefined-event-display condition))))) + (undefined-event-event-name condition) + (undefined-event-display condition))))) (define-condition absent-extension (x-error) ((name :reader absent-extension-name :initarg :name) @@ -1767,15 +1767,15 @@ (:report (lambda (condition stream) (format stream "Extension ~a isn't defined for display ~s" - (absent-extension-name condition) - (absent-extension-display condition))))) + (absent-extension-name condition) + (absent-extension-display condition))))) (define-condition inconsistent-parameters (x-error) ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) (:report (lambda (condition stream) (format stream "inconsistent-parameters:~{ ~s~}" - (inconsistent-parameters-parameters condition))))) + (inconsistent-parameters-parameters condition))))) (define-condition resource-ids-exhausted (x-error) () @@ -1786,22 +1786,22 @@ (defun get-error-key (display error-code) (declare (type display display) - (type array-index error-code)) + (type array-index error-code)) ;; Return the error-key associated with error-code (if (< error-code (length *xerror-vector*)) (svref *xerror-vector* error-code) ;; Search the extensions for the error (dolist (entry (display-extension-alist display) 'unknown-error) (let* ((event-name (first entry)) - (first-error (fourth entry)) - (errors (third (assoc event-name *extensions*)))) - (declare (type keyword event-name) - (type array-index first-error) - (type list errors)) - (when (and errors - (index<= first-error error-code - (index+ first-error (index- (length errors) 1)))) - (return (nth (index- error-code first-error) errors))))))) + (first-error (fourth entry)) + (errors (third (assoc event-name *extensions*)))) + (declare (type keyword event-name) + (type array-index first-error) + (type list errors)) + (when (and errors + (index<= first-error error-code + (index+ first-error (index- (length errors) 1)))) + (return (nth (index- error-code first-error) errors))))))) (defmacro define-error (error-key function) ;; Associate a function with ERROR-KEY which will be called with @@ -1813,12 +1813,12 @@ ;; macros for getting error fields. See DECODE-CORE-ERROR for ;; an example. (declare (type symbol error-key) - (type (or symbol list) function)) + (type (or symbol list) function)) ;; First ensure the name is for a declared extension (unless (or (find error-key *xerror-vector*) - (dolist (extension *extensions*) - (when (member error-key (third extension)) - (return t)))) + (dolist (extension *extensions*) + (when (member error-key (third extension)) + (return t)))) (x-type-error error-key 'error-key)) `(setf (get ',error-key 'error-decode-function) (function ,function))) @@ -1834,19 +1834,19 @@ ;; at byte 4 of the event is returned with the other keyword/argument ;; pairs. (declare (type display display) - (type reply-buffer event) - (type (or null keyword) arg)) + (type reply-buffer event) + (type (or null keyword) arg)) (declare (clx-values keyword/arg-plist)) display (reading-event (event) (let* ((sequence (read-card16 2)) - (minor-code (read-card16 8)) - (major-code (read-card8 10)) - (result (list :major major-code - :minor minor-code - :sequence sequence))) + (minor-code (read-card16 8)) + (major-code (read-card8 10)) + (result (list :major major-code + :minor minor-code + :sequence sequence))) (when arg - (setq result (list* arg (read-card32 4) result))) + (setq result (list* arg (read-card32 4) result))) result))) (defun decode-resource-error (display event) @@ -1855,43 +1855,43 @@ (define-error unknown-error (lambda (display event) (list* :error-code (aref (reply-ibuf8 event) 1) - (decode-core-error display event)))) + (decode-core-error display event)))) -(define-error request-error decode-core-error) ; 1 bad request code +(define-error request-error decode-core-error) ; 1 bad request code -(define-error value-error ; 2 integer parameter out of range +(define-error value-error ; 2 integer parameter out of range (lambda (display event) (decode-core-error display event :value))) -(define-error window-error decode-resource-error) ; 3 parameter not a Window +(define-error window-error decode-resource-error) ; 3 parameter not a Window -(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap +(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap -(define-error atom-error ; 5 parameter not an Atom +(define-error atom-error ; 5 parameter not an Atom (lambda (display event) (decode-core-error display event :atom-id))) -(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor +(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor -(define-error font-error decode-resource-error) ; 7 parameter not a Font +(define-error font-error decode-resource-error) ; 7 parameter not a Font -(define-error match-error decode-core-error) ; 8 parameter mismatch +(define-error match-error decode-core-error) ; 8 parameter mismatch -(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window +(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window -(define-error access-error decode-core-error) ; 10 attempt to access private resource" +(define-error access-error decode-core-error) ; 10 attempt to access private resource" -(define-error alloc-error decode-core-error) ; 11 insufficient resources +(define-error alloc-error decode-core-error) ; 11 insufficient resources -(define-error colormap-error decode-resource-error) ; 12 no such colormap +(define-error colormap-error decode-resource-error) ; 12 no such colormap -(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext +(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext -(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection +(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection -(define-error name-error decode-core-error) ; 15 font or color name does not exist +(define-error name-error decode-core-error) ; 15 font or color name does not exist -(define-error length-error decode-core-error) ; 16 request length incorrect; - ; internal Xlib error +(define-error length-error decode-core-error) ; 16 request length incorrect; + ; internal Xlib error -(define-error implementation-error decode-core-error) ; 17 server is defective +(define-error implementation-error decode-core-error) ; 17 server is defective diff --git a/src/clx/keysyms.lisp b/src/clx/keysyms.lisp index 92fc5ec48..0c6d59f72 100644 --- a/src/clx/keysyms.lisp +++ b/src/clx/keysyms.lisp @@ -3,9 +3,9 @@ ;;; Define lisp character to keysym mappings ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -20,19 +20,19 @@ (in-package :xlib) -(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) -(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) -(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) -(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) -(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) -(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) -(define-keysym-set :cyrillic (keysym 6 0) (keysym 6 255)) -(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) -(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) -(define-keysym-set :special (keysym 9 0) (keysym 9 255)) -(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) -(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) -(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) +(define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) +(define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) +(define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) +(define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) +(define-keysym-set :kana (keysym 4 0) (keysym 4 255)) +(define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) +(define-keysym-set :cyrillic (keysym 6 0) (keysym 6 255)) +(define-keysym-set :greek (keysym 7 0) (keysym 7 255)) +(define-keysym-set :tech (keysym 8 0) (keysym 8 255)) +(define-keysym-set :special (keysym 9 0) (keysym 9 255)) +(define-keysym-set :publish (keysym 10 0) (keysym 10 255)) +(define-keysym-set :apl (keysym 11 0) (keysym 11 255)) +(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) (define-keysym-set :thai (keysym 13 0) (keysym 13 255)) (define-keysym-set :korean (keysym 14 0) (keysym 14 255)) (define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) @@ -43,7 +43,7 @@ (define-keysym-set :currency (keysym 32 0) (keysym 32 255)) (define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) (define-keysym-set :xkb (keysym 254 0) (keysym 254 255)) -(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) +(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) (define-keysym :character-set-switch character-set-switch-keysym) (define-keysym :left-shift left-shift-keysym) @@ -158,12 +158,12 @@ (define-keysym #\~ 126) (progn ;; Semi-standard characters - (define-keysym #\rubout (keysym 255 255)) ; :tty - (define-keysym #\tab (keysym 255 009)) ; :tty - (define-keysym #\linefeed (keysym 255 010)) ; :tty - (define-keysym #\page (keysym 009 227)) ; :special - (define-keysym #\return (keysym 255 013)) ; :tty - (define-keysym #\backspace (keysym 255 008)) ; :tty + (define-keysym #\rubout (keysym 255 255)) ; :tty + (define-keysym #\tab (keysym 255 009)) ; :tty + (define-keysym #\linefeed (keysym 255 010)) ; :tty + (define-keysym #\page (keysym 009 227)) ; :special + (define-keysym #\return (keysym 255 013)) ; :tty + (define-keysym #\backspace (keysym 255 008)) ; :tty ) ;;; these keysym definitions are only correct if the underlying lisp's @@ -183,7 +183,7 @@ #+(or lispm excl) (progn ;; Nonstandard characters - (define-keysym #\escape (keysym 255 027)) ; :tty + (define-keysym #\escape (keysym 255 027)) ; :tty ) #+ti @@ -235,7 +235,7 @@ ) #+ti -(progn ;; There are no 7-bit ascii representations for the following +(progn ;; There are no 7-bit ascii representations for the following ;; European characters, so use int-char to create them to ensure ;; nothing is lost while sending files through the mail. (define-keysym (int-char 192) 192 :lowercase 224) @@ -306,42 +306,42 @@ #+lispm ;; Nonstandard characters (progn - (define-keysym #\center-dot (keysym 183)) ; :latin-1 - (define-keysym #\down-arrow (keysym 008 254)) ; :technical - (define-keysym #\alpha (keysym 007 225)) ; :greek - (define-keysym #\beta (keysym 007 226)) ; :greek - (define-keysym #\and-sign (keysym 008 222)) ; :technical - (define-keysym #\not-sign (keysym 172)) ; :latin-1 - (define-keysym #\epsilon (keysym 007 229)) ; :greek - (define-keysym #\pi (keysym 007 240)) ; :greek - (define-keysym #\lambda (keysym 007 235)) ; :greek - (define-keysym #\gamma (keysym 007 227)) ; :greek - (define-keysym #\delta (keysym 007 228)) ; :greek - (define-keysym #\up-arrow (keysym 008 252)) ; :technical - (define-keysym #\plus-minus (keysym 177)) ; :latin-1 - (define-keysym #\infinity (keysym 008 194)) ; :technical - (define-keysym #\partial-delta (keysym 008 239)) ; :technical - (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl - (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl - (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl - (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl - (define-keysym #\double-arrow (keysym 008 205)) ; :technical - (define-keysym #\left-arrow (keysym 008 251)) ; :technical - (define-keysym #\right-arrow (keysym 008 253)) ; :technical - (define-keysym #\not-equals (keysym 008 189)) ; :technical - (define-keysym #\less-or-equal (keysym 008 188)) ; :technical - (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical - (define-keysym #\equivalence (keysym 008 207)) ; :technical - (define-keysym #\or-sign (keysym 008 223)) ; :technical - (define-keysym #\integral (keysym 008 191)) ; :technical + (define-keysym #\center-dot (keysym 183)) ; :latin-1 + (define-keysym #\down-arrow (keysym 008 254)) ; :technical + (define-keysym #\alpha (keysym 007 225)) ; :greek + (define-keysym #\beta (keysym 007 226)) ; :greek + (define-keysym #\and-sign (keysym 008 222)) ; :technical + (define-keysym #\not-sign (keysym 172)) ; :latin-1 + (define-keysym #\epsilon (keysym 007 229)) ; :greek + (define-keysym #\pi (keysym 007 240)) ; :greek + (define-keysym #\lambda (keysym 007 235)) ; :greek + (define-keysym #\gamma (keysym 007 227)) ; :greek + (define-keysym #\delta (keysym 007 228)) ; :greek + (define-keysym #\up-arrow (keysym 008 252)) ; :technical + (define-keysym #\plus-minus (keysym 177)) ; :latin-1 + (define-keysym #\infinity (keysym 008 194)) ; :technical + (define-keysym #\partial-delta (keysym 008 239)) ; :technical + (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl + (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl + (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl + (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl + (define-keysym #\double-arrow (keysym 008 205)) ; :technical + (define-keysym #\left-arrow (keysym 008 251)) ; :technical + (define-keysym #\right-arrow (keysym 008 253)) ; :technical + (define-keysym #\not-equals (keysym 008 189)) ; :technical + (define-keysym #\less-or-equal (keysym 008 188)) ; :technical + (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical + (define-keysym #\equivalence (keysym 008 207)) ; :technical + (define-keysym #\or-sign (keysym 008 223)) ; :technical + (define-keysym #\integral (keysym 008 191)) ; :technical ;; break isn't null -;; (define-keysym #\null (keysym 255 107)) ; :function - (define-keysym #\clear-input (keysym 255 011)) ; :tty - (define-keysym #\help (keysym 255 106)) ; :function - (define-keysym #\refresh (keysym 255 097)) ; :function - (define-keysym #\abort (keysym 255 105)) ; :function - (define-keysym #\resume (keysym 255 098)) ; :function - (define-keysym #\end (keysym 255 087)) ; :cursor +;; (define-keysym #\null (keysym 255 107)) ; :function + (define-keysym #\clear-input (keysym 255 011)) ; :tty + (define-keysym #\help (keysym 255 106)) ; :function + (define-keysym #\refresh (keysym 255 097)) ; :function + (define-keysym #\abort (keysym 255 105)) ; :function + (define-keysym #\resume (keysym 255 098)) ; :function + (define-keysym #\end (keysym 255 087)) ; :cursor ;;#\universal-quantifier ;;#\existential-quantifier ;;#\circle-plus @@ -352,59 +352,59 @@ (progn ;;#\network ;;#\symbol-help - (define-keysym #\lozenge (keysym 009 224)) ; :special - (define-keysym #\suspend (keysym 255 019)) ; :tty - (define-keysym #\function (keysym 255 032)) ; :function - (define-keysym #\square (keysym 010 231)) ; :publishing - (define-keysym #\circle (keysym 010 230)) ; :publishing - (define-keysym #\triangle (keysym 010 232)) ; :publishing - (define-keysym #\scroll (keysym 255 086)) ; :cursor - (define-keysym #\select (keysym 255 096)) ; :function - (define-keysym #\complete (keysym 255 104)) ; :function + (define-keysym #\lozenge (keysym 009 224)) ; :special + (define-keysym #\suspend (keysym 255 019)) ; :tty + (define-keysym #\function (keysym 255 032)) ; :function + (define-keysym #\square (keysym 010 231)) ; :publishing + (define-keysym #\circle (keysym 010 230)) ; :publishing + (define-keysym #\triangle (keysym 010 232)) ; :publishing + (define-keysym #\scroll (keysym 255 086)) ; :cursor + (define-keysym #\select (keysym 255 096)) ; :function + (define-keysym #\complete (keysym 255 104)) ; :function ) #+ti (progn - (define-keysym #\terminal (keysym 255 032)) ; :function - (define-keysym #\system (keysym 255 096)) ; :function + (define-keysym #\terminal (keysym 255 032)) ; :function + (define-keysym #\system (keysym 255 096)) ; :function (define-keysym #\center-arrow (keysym 255 80)) - (define-keysym #\left-arrow (keysym 255 081)) ; :cursor - (define-keysym #\up-arrow (keysym 255 082)) ; :cursor - (define-keysym #\right-arrow (keysym 255 083)) ; :cursor - (define-keysym #\down-arrow (keysym 255 084)) ; :cursor - (define-keysym #\end (keysym 255 087)) ; :cursor - (define-keysym #\undo (keysym 255 101)) ; :function + (define-keysym #\left-arrow (keysym 255 081)) ; :cursor + (define-keysym #\up-arrow (keysym 255 082)) ; :cursor + (define-keysym #\right-arrow (keysym 255 083)) ; :cursor + (define-keysym #\down-arrow (keysym 255 084)) ; :cursor + (define-keysym #\end (keysym 255 087)) ; :cursor + (define-keysym #\undo (keysym 255 101)) ; :function (define-keysym #\break (keysym 255 107)) - (define-keysym #\keypad-space (keysym 255 128)) ; :keypad - (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad - (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad - (define-keysym #\f1 (keysym 255 145)) ; :keypad - (define-keysym #\f2 (keysym 255 146)) ; :keypad - (define-keysym #\f3 (keysym 255 147)) ; :keypad - (define-keysym #\f4 (keysym 255 148)) ; :keypad - (define-keysym #\f1 (keysym 255 190)) ; :keypad - (define-keysym #\f2 (keysym 255 191)) ; :keypad - (define-keysym #\f3 (keysym 255 192)) ; :keypad - (define-keysym #\f4 (keysym 255 193)) ; :keypad - (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad - (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad - (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad - (define-keysym #\keypad-period (keysym 255 174)) ; :keypad - (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad - (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad - (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad - (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad - (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad - (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad - (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad - (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad - (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad - (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad - (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad - (define-keysym #\f1 (keysym 255 192)) ; :function - (define-keysym #\f2 (keysym 255 193)) ; :function - (define-keysym #\f3 (keysym 255 194)) ; :function - (define-keysym #\f4 (keysym 255 195)) ; :function + (define-keysym #\keypad-space (keysym 255 128)) ; :keypad + (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad + (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad + (define-keysym #\f1 (keysym 255 145)) ; :keypad + (define-keysym #\f2 (keysym 255 146)) ; :keypad + (define-keysym #\f3 (keysym 255 147)) ; :keypad + (define-keysym #\f4 (keysym 255 148)) ; :keypad + (define-keysym #\f1 (keysym 255 190)) ; :keypad + (define-keysym #\f2 (keysym 255 191)) ; :keypad + (define-keysym #\f3 (keysym 255 192)) ; :keypad + (define-keysym #\f4 (keysym 255 193)) ; :keypad + (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad + (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad + (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad + (define-keysym #\keypad-period (keysym 255 174)) ; :keypad + (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad + (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad + (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad + (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad + (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad + (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad + (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad + (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad + (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad + (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad + (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad + (define-keysym #\f1 (keysym 255 192)) ; :function + (define-keysym #\f2 (keysym 255 193)) ; :function + (define-keysym #\f3 (keysym 255 194)) ; :function + (define-keysym #\f4 (keysym 255 195)) ; :function (define-keysym #\network (keysym 255 214)) (define-keysym #\status (keysym 255 215)) (define-keysym #\clear-screen (keysym 255 217)) @@ -412,22 +412,22 @@ (define-keysym #\middle (keysym 255 219)) (define-keysym #\right (keysym 255 220)) (define-keysym #\resume (keysym 255 221)) - (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete + (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete ) #+ti (progn ;; Explorer specific characters - (define-keysym #\Call (keysym 131)) ; :latin-1 - (define-keysym #\Macro (keysym 133)) ; :latin-1 - (define-keysym #\Quote (keysym 142)) ; :latin-1 - (define-keysym #\Hold-output (keysym 143)) ; :latin-1 - (define-keysym #\Stop-output (keysym 144)) ; :latin-1 - (define-keysym #\Center (keysym 156)) ; :latin-1 - (define-keysym #\no-break-space (keysym 160)) ; :latin-1 + (define-keysym #\Call (keysym 131)) ; :latin-1 + (define-keysym #\Macro (keysym 133)) ; :latin-1 + (define-keysym #\Quote (keysym 142)) ; :latin-1 + (define-keysym #\Hold-output (keysym 143)) ; :latin-1 + (define-keysym #\Stop-output (keysym 144)) ; :latin-1 + (define-keysym #\Center (keysym 156)) ; :latin-1 + (define-keysym #\no-break-space (keysym 160)) ; :latin-1 - (define-keysym #\circle-plus (keysym 13)) ; :latin-1 - (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 - (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 - (define-keysym #\circle-cross (keysym 22)) ; :latin-1 + (define-keysym #\circle-plus (keysym 13)) ; :latin-1 + (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 + (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 + (define-keysym #\circle-cross (keysym 22)) ; :latin-1 ) diff --git a/src/clx/macros.lisp b/src/clx/macros.lisp index 24e1c405a..ff0fe4c34 100644 --- a/src/clx/macros.lisp +++ b/src/clx/macros.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -39,7 +39,7 @@ ;;; An error signalling macro use to specify that keyword arguments are required. (defmacro required-arg (name) `(progn (x-error 'missing-parameter :parameter ',name) - *required-arg-dummy*)) + *required-arg-dummy*)) (defmacro lround (index) ;; Round up to the next 32 bit boundary @@ -59,14 +59,14 @@ (defun index-increment (type) ;; Given a type, return its field width in bytes (let* ((name (if (consp type) (car type) type)) - (increment (get name 'byte-width :not-found))) + (increment (get name 'byte-width :not-found))) (when (eq increment :not-found) ;; Check for TYPE in a different package (when (not (eq (symbol-package name) *xlib-package*)) - (setq name (xintern name)) - (setq increment (get name 'byte-width :not-found))) + (setq name (xintern name)) + (setq increment (get name 'byte-width :not-found))) (when (eq increment :not-found) - (error "~s isn't a known field accessor" name))) + (error "~s isn't a known field accessor" name))) increment)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -89,19 +89,19 @@ (when (cdddr get-put-macros) (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) - (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) + (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) `(within-definition (,name define-accessor) (setf (get ',name 'byte-width) ,(and width (floor width 8))) (defmacro ,(getify name) ,(car get-macro) - ,@(cdr get-macro)) + ,@(cdr get-macro)) (defmacro ,(putify name) ,(car put-macro) - ,@(cdr put-macro)) + ,@(cdr put-macro)) ,@(when +type-check?+ - (let ((predicating-put (third get-put-macros))) - (when predicating-put - `((setf (get ',name 'predicating-put) t) - (defmacro ,(putify name t) ,(car predicating-put) - ,@(cdr predicating-put))))))))) + (let ((predicating-put (third get-put-macros))) + (when predicating-put + `((setf (get ',name 'predicating-put) t) + (defmacro ,(putify name t) ,(car predicating-put) + ,@(cdr predicating-put))))))))) ) ;; End eval-when (define-accessor card32 (32) @@ -198,7 +198,7 @@ `(atom-name ,buffer (read-card29 ,index))) ((index thing &key (buffer '%buffer)) `(write-card29 ,index (or (atom-id ,thing ,buffer) - (error "CLX implementation error in KEYWORD-PUT"))))) + (error "CLX implementation error in KEYWORD-PUT"))))) (define-accessor resource-id (32) ((index) `(read-card29 ,index)) @@ -206,79 +206,79 @@ (define-accessor resource-id-or-nil (32) ((index) (let ((id (gensym))) - `(let ((,id (read-card29 ,index))) - (and (plusp ,id) ,id)))) + `(let ((,id (read-card29 ,index))) + (and (plusp ,id) ,id)))) ((index thing) `(write-card29 ,index (or ,thing 0)))) (defmacro char-info-get (index) `(make-char-info :left-bearing (int16-get ,index) :right-bearing (int16-get ,(+ index 2)) - :width (int16-get ,(+ index 4)) - :ascent (int16-get ,(+ index 6)) - :descent (int16-get ,(+ index 8)) + :width (int16-get ,(+ index 4)) + :ascent (int16-get ,(+ index 6)) + :descent (int16-get ,(+ index 8)) :attributes (card16-get ,(+ index 10)))) (define-accessor member8 (8) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card8 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) + (declare (type (integer 0 (,(length keywords))) ,value)) + (type-check ,value '(integer 0 (,(length keywords)))) + (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card8 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card8 ,index ,value)))))) + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card8 ,index ,value)))))) (define-accessor member16 (16) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card16 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) + (declare (type (integer 0 (,(length keywords))) ,value)) + (type-check ,value '(integer 0 (,(length keywords)))) + (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card16 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card16 ,index ,value)))))) + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card16 ,index ,value)))))) (define-accessor member (32) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length keywords))) ,value)) - (type-check ,value '(integer 0 (,(length keywords)))) - (svref ',(apply #'vector keywords) ,value)))) + (declare (type (integer 0 (,(length keywords))) ,value)) + (type-check ,value '(integer 0 (,(length keywords)))) + (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card29 ,index (position ,thing - #+lispm ',keywords ;; Lispm's prefer lists - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) + #+lispm ',keywords ;; Lispm's prefer lists + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) ((index thing &rest keywords) (if (cdr keywords) ;; IF more than one (let ((value (gensym))) - `(let ((,value (position ,thing - #+lispm ',keywords - #-lispm (the simple-vector ',(apply #'vector keywords)) - :test #'eq))) - (and ,value (write-card29 ,index ,value)))) + `(let ((,value (position ,thing + #+lispm ',keywords + #-lispm (the simple-vector ',(apply #'vector keywords)) + :test #'eq))) + (and ,value (write-card29 ,index ,value)))) `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) @@ -312,15 +312,15 @@ ((index) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) - (declare (type (integer 0 (,(length +boole-vector+))) ,value)) - (type-check ,value '(integer 0 (,(length +boole-vector+)))) - (svref +boole-vector+ ,value)))) + (declare (type (integer 0 (,(length +boole-vector+))) ,value)) + (type-check ,value '(integer 0 (,(length +boole-vector+)))) + (svref +boole-vector+ ,value)))) ((index thing) `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) ((index thing) (let ((value (gensym))) `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) - (and ,value (write-card29 ,index ,value)))))) + (and ,value (write-card29 ,index ,value)))))) (define-accessor null (32) ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) @@ -356,23 +356,23 @@ (unless buffer (setq buffer '%buffer)) (unless header-length (setq header-length (lround index))) (let* ((real-end (if appending (or end `(length ,string)) (gensym))) - (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) - ,string ,start ,real-end))) + (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) + ,string ,start ,real-end))) (if appending - form + form `(let ((,real-end ,(or end `(length ,string)))) - (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) - ,form))))) + (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) + ,form))))) (define-accessor sequence (nil) ((&key length (format 'card32) result-type transform reply-buffer data index start) `(,(ecase format - (card8 'read-sequence-card8) - (int8 'read-sequence-int8) - (card16 'read-sequence-card16) - (int16 'read-sequence-int16) - (card32 'read-sequence-card32) - (int32 'read-sequence-int32)) + (card8 'read-sequence-card8) + (int8 'read-sequence-int8) + (card16 'read-sequence-card16) + (int16 'read-sequence-int16) + (card32 'read-sequence-card32) + (int32 'read-sequence-int32)) ,(or reply-buffer '%reply-buffer) ,result-type ,length ,transform ,data ,@(when (or start index) `(,(or start 0))) @@ -380,57 +380,57 @@ ((index data &key (format 'card32) (start 0) end transform buffer appending) (unless buffer (setq buffer '%buffer)) (let* ((real-end (if appending (or end `(length ,data)) (gensym))) - (writer (xintern 'write-sequence- format)) - (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) - ,data ,start ,real-end ,transform))) + (writer (xintern 'write-sequence- format)) + (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) + ,data ,start ,real-end ,transform))) (flet ((maker (size) - (if appending - form - (let ((idx `(index- ,real-end ,start))) - (unless (= size 1) - (setq idx `(index-ceiling ,idx ,size))) - `(let ((,real-end ,(or end `(length ,data)))) - (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) - ,form))))) + (if appending + form + (let ((idx `(index- ,real-end ,start))) + (unless (= size 1) + (setq idx `(index-ceiling ,idx ,size))) + `(let ((,real-end ,(or end `(length ,data)))) + (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) + ,form))))) (ecase format - ((card8 int8) - (maker 4)) - ((card16 int16 char2b) - (maker 2)) - ((card32 int32) - (maker 1))))))) + ((card8 int8) + (maker 4)) + ((card16 int16 char2b) + (maker 2)) + ((card32 int32) + (maker 1))))))) (defmacro client-message-event-get-sequence () '(let* ((format (read-card8 1)) - (sequence (make-array (ceiling 160 format) - :element-type `(unsigned-byte ,format)))) + (sequence (make-array (ceiling 160 format) + :element-type `(unsigned-byte ,format)))) (declare (type (member 8 16 32) format)) (do ((i 12) - (j 0 (index1+ j))) - ((>= i 32)) + (j 0 (index1+ j))) + ((>= i 32)) (case format - (8 (setf (aref sequence j) (read-card8 i)) - (index-incf i)) - (16 (setf (aref sequence j) (read-card16 i)) - (index-incf i 2)) - (32 (setf (aref sequence j) (read-card32 i)) - (index-incf i 4)))) + (8 (setf (aref sequence j) (read-card8 i)) + (index-incf i)) + (16 (setf (aref sequence j) (read-card16 i)) + (index-incf i 2)) + (32 (setf (aref sequence j) (read-card32 i)) + (index-incf i 4)))) sequence)) (defmacro client-message-event-put-sequence (format sequence) `(ecase ,format (8 (sequence-put 12 ,sequence - :format card8 - :end (min (length ,sequence) 20) - :appending t)) + :format card8 + :end (min (length ,sequence) 20) + :appending t)) (16 (sequence-put 12 ,sequence - :format card16 - :end (min (length ,sequence) 10) - :appending t)) + :format card16 + :end (min (length ,sequence) 10) + :appending t)) (32 (sequence-put 12 ,sequence - :format card32 - :end (min (length ,sequence) 5) - :appending t)))) + :format card32 + :end (min (length ,sequence) 5) + :appending t)))) ;; Used only in declare-event (define-accessor client-message-sequence (160) @@ -460,23 +460,23 @@ ((index &optional stuff) (declare (ignore index)) (if stuff (if (consp stuff) - `(,(getify (car stuff)) 1 ,@(cdr stuff)) - `(,(getify stuff) 1)) + `(,(getify (car stuff)) 1 ,@(cdr stuff)) + `(,(getify stuff) 1)) `(read-card8 1))) ((index thing &optional stuff) (if stuff (if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing)) + `(macrolet ((write-card32 (index value) index value)) + (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) + `(,(putify stuff) 1 ,thing)) `(write-card8 1 ,thing))) ((index thing &optional stuff) (if stuff `(and (type? ,thing ',stuff) - ,(if (consp stuff) - `(macrolet ((write-card32 (index value) index value)) - (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) - `(,(putify stuff) 1 ,thing))) + ,(if (consp stuff) + `(macrolet ((write-card32 (index value) index value)) + (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) + `(,(putify stuff) 1 ,thing))) `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded @@ -484,10 +484,10 @@ (defmacro or-expand (&rest forms &environment environment) `(cond ,@(mapcar #'(lambda (forms) - (mapcar #'(lambda (form) - (clx-macroexpand form environment)) - forms)) - forms))) + (mapcar #'(lambda (form) + (clx-macroexpand form environment)) + forms)) + forms))) ;; ;; the OR type @@ -496,43 +496,43 @@ ;; Select from among several types (usually NULL and something else) ((index &rest type-list &environment environment) (do ((types type-list (cdr types)) - (value (gensym)) - (result)) + (value (gensym)) + (result)) ((endp types) - `(let ((,value (read-card32 ,index))) - (macrolet ((read-card32 (index) index ',value) - (read-card29 (index) index ',value)) - ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) + `(let ((,value (read-card32 ,index))) + (macrolet ((read-card32 (index) index ',value) + (read-card29 (index) index ',value)) + ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) (let ((item (car types)) - (args nil)) + (args nil)) (when (consp item) - (setq args (cdr item) - item (car item))) + (setq args (cdr item) + item (car item))) (if (eq item 'null) ;; Special case for NULL - (push `((zerop ,value) nil) result) - (push - `((,(getify item) ,index ,@args)) - result))))) + (push `((zerop ,value) nil) result) + (push + `((,(getify item) ,index ,@args)) + result))))) ((index value &rest type-list) (do ((types type-list (cdr types)) - (result)) + (result)) ((endp types) - `(cond ,@(nreverse result) - ,@(when +type-check?+ - `((t (x-type-error ,value '(or ,@type-list))))))) + `(cond ,@(nreverse result) + ,@(when +type-check?+ + `((t (x-type-error ,value '(or ,@type-list))))))) (let* ((type (car types)) - (type-name type) - (args nil)) + (type-name type) + (args nil)) (when (consp type) - (setq args (cdr type) - type-name (car type))) + (setq args (cdr type) + type-name (car type))) (push - `(,@(cond ((get type-name 'predicating-put) nil) - ((or +type-check?+ (cdr types)) `((type? ,value ',type))) - (t '(t))) - (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) - result))))) + `(,@(cond ((get type-name 'predicating-put) nil) + ((or +type-check?+ (cdr types)) `((type? ,value ',type))) + (t '(t))) + (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) + result))))) ;; ;; the MASK type... @@ -544,63 +544,63 @@ (defun mask-get (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg body-function)) ;; This is a function, because it must return more than one form (called by get-put-items) ;; Functions that use this must have a binding for %MASK (let* ((bit 0) - (result - (mapcar - #'(lambda (form) - (if (atom form) - form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs - (prog1 - `(when (logbitp ,bit %mask) - ;; Execute form when bit is set - ,form) - (incf bit)))) - (get-put-items - (+ index 4) type-values nil - #'(lambda (type index item args) - (declare (ignore index)) - (funcall body-function type '(* (incf %index) 4) item args)))))) + (result + (mapcar + #'(lambda (form) + (if (atom form) + form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs + (prog1 + `(when (logbitp ,bit %mask) + ;; Execute form when bit is set + ,form) + (incf bit)))) + (get-put-items + (+ index 4) type-values nil + #'(lambda (type index item args) + (declare (ignore index)) + (funcall body-function type '(* (incf %index) 4) item args)))))) ;; First form must load %MASK `(,@(when (atom (car result)) - (list (pop result))) + (list (pop result))) (progn (setq %mask (read-card32 ,index)) - (setq %index ,(ceiling index 4)) - ,(car result)) + (setq %index ,(ceiling index 4)) + ,(car result)) ,@(cdr result)))) ;; MASK-PUT (defun mask-put (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg body-function)) ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES ;; A 32 bit value follows for each non-nil value. `((let ((%mask 0) - (%index ,index)) + (%index ,index)) ,@(let ((bit 1)) - (get-put-items - index type-values t - #'(lambda (type index item args) - (declare (ignore index)) - (if (or (symbolp item) (constantp item)) - `((unless (null ,item) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) item args))) - `((let ((.item. ,item)) - (unless (null .item.) - (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) - ,@(funcall body-function type - `(index-incf %index 4) '.item. args)))))))) + (get-put-items + index type-values t + #'(lambda (type index item args) + (declare (ignore index)) + (if (or (symbolp item) (constantp item)) + `((unless (null ,item) + (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) + ,@(funcall body-function type + `(index-incf %index 4) item args))) + `((let ((.item. ,item)) + (unless (null .item.) + (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) + ,@(funcall body-function type + `(index-incf %index 4) '.item. args)))))))) (write-card32 ,index %mask) (write-card16 2 (index-ceiling (index-incf %index 4) 4)) (incf (buffer-boffset %buffer) %index)))) @@ -620,178 +620,178 @@ (defmacro check-put (index value type &rest args &environment env) (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) - (body - (if (or (null (macroexpand `(type-check ,var ',type) env)) - (member type '(or progn pad8 pad16)) - (constantp value)) - `(,(putify type) ,index ,var ,@args) - ;; Do type checking - (if (get type 'predicating-put) - `(or (,(putify type t) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))) - `(if (type? ,var ',type) - (,(putify type) ,index ,var ,@args) - (x-type-error ,var ',(if args `(,type ,@args) type))))))) + (body + (if (or (null (macroexpand `(type-check ,var ',type) env)) + (member type '(or progn pad8 pad16)) + (constantp value)) + `(,(putify type) ,index ,var ,@args) + ;; Do type checking + (if (get type 'predicating-put) + `(or (,(putify type t) ,index ,var ,@args) + (x-type-error ,var ',(if args `(,type ,@args) type))) + `(if (type? ,var ',type) + (,(putify type) ,index ,var ,@args) + (x-type-error ,var ',(if args `(,type ,@args) type))))))) (if (eq var value) - body + body `(let ((,var ,value)) - ,body)))) + ,body)))) (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + #+clx-ansi-common-lisp + (dynamic-extent body-function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg body-function)) ;; Given a lists of the form (type item item ... item) ;; Calls body-function with four arguments, a function name, ;; index, item name, and optional arguments. ;; The results are appended together and retured. (unless body-function (setq body-function - #'(lambda (type index item args) - `((check-put ,index ,item ,type ,@args))))) + #'(lambda (type index item args) + `((check-put ,index ,item ,type ,@args))))) (do* ((items type-args (cdr items)) - (type (caar items) (caar items)) - (args nil nil) - (result nil) - (sizes nil)) + (type (caar items) (caar items)) + (args nil nil) + (result nil) + (sizes nil)) ((endp items) (values result index sizes)) (when (consp type) (setq args (cdr type) - type (car type))) + type (car type))) (cond ((member type '(return buffer))) - ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values - (setq result - (append result (if putp - (mask-put index (cdar items) body-function) - (mask-get index (cdar items) body-function))) - index nil)) - (t (do* ((item (cdar items) (cdr item)) - (increment (index-increment type))) - ((endp item)) - (when (constantp index) - (case increment ;Round up index when needed - (2 (setq index (wround index))) - (4 (setq index (lround index))))) - (setq result - (append result (funcall body-function type index (car item) args))) - (when (constantp index) - ;; Variable length requests have null length increment. - ;; Variable length requests set the request size - ;; & maintain buffer pointers - (if (null increment) - (setq index nil) - (progn - (incf index increment) - (when (and increment (zerop increment)) (setq increment 1)) - (pushnew (* increment 8) sizes))))))))) + ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values + (setq result + (append result (if putp + (mask-put index (cdar items) body-function) + (mask-get index (cdar items) body-function))) + index nil)) + (t (do* ((item (cdar items) (cdr item)) + (increment (index-increment type))) + ((endp item)) + (when (constantp index) + (case increment ;Round up index when needed + (2 (setq index (wround index))) + (4 (setq index (lround index))))) + (setq result + (append result (funcall body-function type index (car item) args))) + (when (constantp index) + ;; Variable length requests have null length increment. + ;; Variable length requests set the request size + ;; & maintain buffer pointers + (if (null increment) + (setq index nil) + (progn + (incf index increment) + (when (and increment (zerop increment)) (setq increment 1)) + (pushnew (* increment 8) sizes))))))))) (defmacro with-buffer-request-internal - ((buffer opcode &key length sizes &allow-other-keys) - &body type-args) + ((buffer opcode &key length sizes &allow-other-keys) + &body type-args) (multiple-value-bind (code index item-sizes) (get-put-items 4 type-args t) (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) - (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) + (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) `(with-buffer-output (,buffer :length ,length :sizes ,sizes) - (setf (buffer-last-request ,buffer) buffer-boffset) - (write-card8 0 ,opcode) ;; Stick in the opcode - ,@code - ,@(when index - (setq index (lround index)) - `((write-card16 2 ,(ceiling index 4)) - (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) - (buffer-new-request-number ,buffer))))) + (setf (buffer-last-request ,buffer) buffer-boffset) + (write-card8 0 ,opcode) ;; Stick in the opcode + ,@code + ,@(when index + (setq index (lround index)) + `((write-card16 2 ,(ceiling index 4)) + (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) + (buffer-new-request-number ,buffer))))) (defmacro with-buffer-request - ((buffer opcode &rest options &key inline gc-force &allow-other-keys) - &body type-args &environment env) + ((buffer opcode &rest options &key inline gc-force &allow-other-keys) + &body type-args &environment env) (if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args))) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body.)) - (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) - 'with-buffer-request-function-nolock - 'with-buffer-request-function) - ,buffer ,gc-force #'.request-body.)) + (declare (type display .display.)) + (with-buffer-request-internal (.display. ,opcode ,@options) + ,@type-args))) + #+clx-ansi-common-lisp + (declare (dynamic-extent #'.request-body.)) + (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) + 'with-buffer-request-function-nolock + 'with-buffer-request-function) + ,buffer ,gc-force #'.request-body.)) `(let ((.display. ,buffer)) (declare (type display .display.)) (with-buffer (.display.) - ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) - (multiple-value-prog1 - (without-aborts - (with-buffer-request-internal (.display. ,opcode ,@options) - ,@type-args)) - (display-invoke-after-function .display.)))))) + ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) + (multiple-value-prog1 + (without-aborts + (with-buffer-request-internal (.display. ,opcode ,@options) + ,@type-args)) + (display-invoke-after-function .display.)))))) (defmacro with-buffer-request-and-reply - ((buffer opcode reply-size &key sizes multiple-reply inline) - type-args &body reply-forms &environment env) + ((buffer opcode reply-size &key sizes multiple-reply inline) + type-args &body reply-forms &environment env) (declare (indentation 0 4 1 4 2 1)) (let* ((inner-reply-body - `(with-buffer-input (.reply-buffer. :display .display. - ,@(and sizes (list :sizes sizes))) - nil ,@reply-forms)) - (reply-body - (if (or (not (symbolp reply-size)) (constantp reply-size)) - inner-reply-body - `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) - (declare (type array-index ,reply-size)) - ,inner-reply-body)))) + `(with-buffer-input (.reply-buffer. :display .display. + ,@(and sizes (list :sizes sizes))) + nil ,@reply-forms)) + (reply-body + (if (or (not (symbolp reply-size)) (constantp reply-size)) + inner-reply-body + `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) + (declare (type array-index ,reply-size)) + ,inner-reply-body)))) (if (and (null inline) (macroexpand '(use-closures) env)) - `(flet ((.request-body. (.display.) - (declare (type display .display.)) - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (.reply-body. (.display. .reply-buffer.) - (declare (type display .display.) - (type reply-buffer .reply-buffer.)) - (progn .display. .reply-buffer. nil) - ,reply-body)) - #+clx-ansi-common-lisp - (declare (dynamic-extent #'.request-body. #'.reply-body.)) - (with-buffer-request-and-reply-function - ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) + `(flet ((.request-body. (.display.) + (declare (type display .display.)) + (with-buffer-request-internal (.display. ,opcode) + ,@type-args)) + (.reply-body. (.display. .reply-buffer.) + (declare (type display .display.) + (type reply-buffer .reply-buffer.)) + (progn .display. .reply-buffer. nil) + ,reply-body)) + #+clx-ansi-common-lisp + (declare (dynamic-extent #'.request-body. #'.reply-body.)) + (with-buffer-request-and-reply-function + ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) `(let ((.display. ,buffer) - (.pending-command. nil) - (.reply-buffer. nil)) - (declare (type display .display.) - (type (or null pending-command) .pending-command.) - (type (or null reply-buffer) .reply-buffer.)) - (unwind-protect - (progn - (with-buffer (.display.) - (setq .pending-command. (start-pending-command .display.)) - (without-aborts - (with-buffer-request-internal (.display. ,opcode) - ,@type-args)) - (buffer-force-output .display.) - (display-invoke-after-function .display.)) - ,@(if multiple-reply - `((loop - (setq .reply-buffer. (read-reply .display. .pending-command.)) - (when ,reply-body (return nil)) - (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) - `((setq .reply-buffer. (read-reply .display. .pending-command.)) - ,reply-body))) - (when .reply-buffer. - (deallocate-reply-buffer .reply-buffer.)) - (when .pending-command. - (stop-pending-command .display. .pending-command.))))))) + (.pending-command. nil) + (.reply-buffer. nil)) + (declare (type display .display.) + (type (or null pending-command) .pending-command.) + (type (or null reply-buffer) .reply-buffer.)) + (unwind-protect + (progn + (with-buffer (.display.) + (setq .pending-command. (start-pending-command .display.)) + (without-aborts + (with-buffer-request-internal (.display. ,opcode) + ,@type-args)) + (buffer-force-output .display.) + (display-invoke-after-function .display.)) + ,@(if multiple-reply + `((loop + (setq .reply-buffer. (read-reply .display. .pending-command.)) + (when ,reply-body (return nil)) + (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) + `((setq .reply-buffer. (read-reply .display. .pending-command.)) + ,reply-body))) + (when .reply-buffer. + (deallocate-reply-buffer .reply-buffer.)) + (when .pending-command. + (stop-pending-command .display. .pending-command.))))))) (defmacro compare-request ((index) &body body) `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) - (write-int32 (index item) `(= ,item (read-int32 ,index))) - (write-card29 (index item) `(= ,item (read-card29 ,index))) - (write-int29 (index item) `(= ,item (read-int29 ,index))) - (write-card16 (index item) `(= ,item (read-card16 ,index))) - (write-int16 (index item) `(= ,item (read-int16 ,index))) - (write-card8 (index item) `(= ,item (read-card8 ,index))) - (write-int8 (index item) `(= ,item (read-int8 ,index)))) + (write-int32 (index item) `(= ,item (read-int32 ,index))) + (write-card29 (index item) `(= ,item (read-card29 ,index))) + (write-int29 (index item) `(= ,item (read-int29 ,index))) + (write-card16 (index item) `(= ,item (read-card16 ,index))) + (write-int16 (index item) `(= ,item (read-int16 ,index))) + (write-card8 (index item) `(= ,item (read-card8 ,index))) + (write-int8 (index item) `(= ,item (read-int8 ,index)))) (macrolet ((type-check (value type) value type nil)) (and ,@(get-put-items index body t))))) @@ -803,14 +803,14 @@ (let ((args nil)) (when (consp type) (setq args (cdr type) - type (car type))) + type (car type))) `(macrolet ((read-card29 (value) value) - (read-card32 (value) value) - (read-int32 (value) `(card32->int32 ,value)) - (read-card16 (value) value) - (read-int16 (value) `(card16->int16 ,value)) - (read-card8 (value) value) - (read-int8 (value) `(int8->card8 ,value))) + (read-card32 (value) value) + (read-int32 (value) `(card32->int32 ,value)) + (read-card16 (value) value) + (read-int16 (value) `(card16->int16 ,value)) + (read-card8 (value) value) + (read-int8 (value) `(int8->card8 ,value))) (,(getify type) ,value ,@args)))) (defmacro encode-type (type value) @@ -819,14 +819,14 @@ (let ((args nil)) (when (consp type) (setq args (cdr type) - type (car type))) + type (car type))) `(macrolet ((write-card29 (index value) index value) - (write-card32 (index value) index value) - (write-int32 (index value) index `(int32->card32 ,value)) - (write-card16 (index value) index value) - (write-int16 (index value) index `(int16->card16 ,value)) - (write-card8 (index value) index value) - (write-int8 (index value) index `(int8->card8 ,value))) + (write-card32 (index value) index value) + (write-int32 (index value) index `(int32->card32 ,value)) + (write-card16 (index value) index value) + (write-int16 (index value) index `(int16->card16 ,value)) + (write-card8 (index value) index value) + (write-int8 (index value) index `(int8->card8 ,value))) (check-put 0 ,value ,type ,@args)))) (defmacro set-decode-type (type accessor value) @@ -887,7 +887,7 @@ (defconstant +x-queryfont+ 47) (defconstant +x-querytextextents+ 48) (defconstant +x-listfonts+ 49) -(defconstant +x-listfontswithinfo+ 50) +(defconstant +x-listfontswithinfo+ 50) (defconstant +x-setfontpath+ 51) (defconstant +x-getfontpath+ 52) (defconstant +x-createpixmap+ 53) @@ -951,66 +951,66 @@ (defconstant +x-changeaccesscontrol+ 111) (defconstant +x-changeclosedownmode+ 112) (defconstant +x-killclient+ 113) -(defconstant +x-rotateproperties+ 114) -(defconstant +x-forcescreensaver+ 115) +(defconstant +x-rotateproperties+ 114) +(defconstant +x-forcescreensaver+ 115) (defconstant +x-setpointermapping+ 116) (defconstant +x-getpointermapping+ 117) -(defconstant +x-setmodifiermapping+ 118) -(defconstant +x-getmodifiermapping+ 119) +(defconstant +x-setmodifiermapping+ 118) +(defconstant +x-getmodifiermapping+ 119) (defconstant +x-nooperation+ 127) ;;; Some macros for threaded lists (defmacro threaded-atomic-push (item list next type) (let ((x (gensym)) - (y (gensym))) + (y (gensym))) `(let ((,x ,item)) (declare (type ,type ,x)) (loop - (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (setf (,next ,x) ,y) - (when (conditional-store ,list ,y ,x) - (return ,x))))))) + (let ((,y ,list)) + (declare (type (or null ,type) ,y) + (optimize (speed 3) (safety 0))) + (setf (,next ,x) ,y) + (when (conditional-store ,list ,y ,x) + (return ,x))))))) (defmacro threaded-atomic-pop (list next type) (let ((y (gensym))) `(loop (let ((,y ,list)) - (declare (type (or null ,type) ,y) - (optimize (speed 3) (safety 0))) - (if (null ,y) - (return nil) - (when (conditional-store ,list ,y (,next (the ,type ,y))) - (setf (,next (the ,type ,y)) nil) - (return ,y))))))) + (declare (type (or null ,type) ,y) + (optimize (speed 3) (safety 0))) + (if (null ,y) + (return nil) + (when (conditional-store ,list ,y (,next (the ,type ,y))) + (setf (,next (the ,type ,y)) nil) + (return ,y))))))) (defmacro threaded-nconc (item list next type) (let ((first (gensym)) - (x (gensym)) - (y (gensym)) - (z (gensym))) + (x (gensym)) + (y (gensym)) + (z (gensym))) `(let ((,z ,item) - (,first ,list)) + (,first ,list)) (declare (type ,type ,z) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) + (type (or null ,type) ,first) + (optimize (speed 3) (safety 0))) (if (null ,first) - (setf ,list ,z) - (do* ((,x ,first ,y) - (,y (,next ,x) (,next ,x))) - ((null ,y) - (setf (,next ,x) ,z) - ,first) - (declare (type ,type ,x) - (type (or null ,type) ,y))))))) + (setf ,list ,z) + (do* ((,x ,first ,y) + (,y (,next ,x) (,next ,x))) + ((null ,y) + (setf (,next ,x) ,z) + ,first) + (declare (type ,type ,x) + (type (or null ,type) ,y))))))) (defmacro threaded-push (item list next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (shiftf (,next ,x) ,list ,x) ,x))) @@ -1018,80 +1018,80 @@ (let ((x (gensym))) `(let ((,x ,list)) (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (when ,x - (shiftf ,list (,next (the ,type ,x)) nil)) + (shiftf ,list (,next (the ,type ,x)) nil)) ,x))) (defmacro threaded-enqueue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (if (null ,tail) - (threaded-nconc ,x ,head ,next ,type) - (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) + (threaded-nconc ,x ,head ,next ,type) + (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) (setf ,tail ,x)))) (defmacro threaded-dequeue (head tail next type) (let ((x (gensym))) `(let ((,x ,head)) (declare (type (or null ,type) ,x) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (when ,x - (when (eq ,x ,tail) - (setf ,tail (,next (the ,type ,x)))) - (setf ,head (,next (the ,type ,x)))) + (when (eq ,x ,tail) + (setf ,tail (,next (the ,type ,x)))) + (setf ,head (,next (the ,type ,x)))) ,x))) (defmacro threaded-requeue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (if (null ,tail) - (setf ,tail (setf ,head ,x)) - (shiftf (,next ,x) ,head ,x)) + (setf ,tail (setf ,head ,x)) + (shiftf (,next ,x) ,head ,x)) ,x))) (defmacro threaded-dolist ((variable list next type) &body body) `(block nil (do* ((,variable ,list (,next (the ,type ,variable)))) - ((null ,variable)) + ((null ,variable)) (declare (type (or null ,type) ,variable)) ,@body))) (defmacro threaded-delete (item list next type) (let ((x (gensym)) - (y (gensym)) - (z (gensym)) - (first (gensym))) + (y (gensym)) + (z (gensym)) + (first (gensym))) `(let ((,x ,item) - (,first ,list)) + (,first ,list)) (declare (type ,type ,x) - (type (or null ,type) ,first) - (optimize (speed 3) (safety 0))) + (type (or null ,type) ,first) + (optimize (speed 3) (safety 0))) (when ,first - (if (eq ,first ,x) - (setf ,first (setf ,list (,next ,x))) - (do* ((,y ,first ,z) - (,z (,next ,y) (,next ,y))) - ((or (null ,z) (eq ,z ,x)) - (when (eq ,z ,x) - (setf (,next ,y) (,next ,x)))) - (declare (type ,type ,y)) - (declare (type (or null ,type) ,z))))) + (if (eq ,first ,x) + (setf ,first (setf ,list (,next ,x))) + (do* ((,y ,first ,z) + (,z (,next ,y) (,next ,y))) + ((or (null ,z) (eq ,z ,x)) + (when (eq ,z ,x) + (setf (,next ,y) (,next ,x)))) + (declare (type ,type ,y)) + (declare (type (or null ,type) ,z))))) (setf (,next ,x) nil) ,first))) (defmacro threaded-length (list next type) (let ((x (gensym)) - (count (gensym))) + (count (gensym))) `(do ((,x ,list (,next (the ,type ,x))) - (,count 0 (index1+ ,count))) - ((null ,x) - ,count) + (,count 0 (index1+ ,count))) + ((null ,x) + ,count) (declare (type (or null ,type) ,x) - (type array-index ,count) - (optimize (speed 3) (safety 0)))))) + (type array-index ,count) + (optimize (speed 3) (safety 0)))))) diff --git a/src/clx/manager.lisp b/src/clx/manager.lisp index 57aa7b1c1..dffe3a9bb 100644 --- a/src/clx/manager.lisp +++ b/src/clx/manager.lisp @@ -3,9 +3,9 @@ ;;; Window Manager Property functions ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -30,8 +30,8 @@ (defun set-string-property (window property string) (declare (type window window) - (type keyword property) - (type stringable string)) + (type keyword property) + (type stringable string)) (change-property window property (string string) :STRING 8 :transform #'char->card8) string) @@ -39,7 +39,7 @@ (declare (type window window)) (declare (clx-values string)) (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) + :result-type 'string :transform #'card8->char)) (defsetf wm-icon-name (window) (name) `(set-string-property ,window :WM_ICON_NAME ,name)) @@ -48,7 +48,7 @@ (declare (type window window)) (declare (clx-values string)) (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) + :result-type 'string :transform #'card8->char)) (defsetf wm-client-machine (window) (name) `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) @@ -60,26 +60,26 @@ (declare (type (or null (vector card8)) value)) (when value (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class + (name (subseq (the (vector card8) value) 0 name-len)) + (class (when name-len (subseq (the (vector card8) value) (1+ name-len) (position 0 (the (vector card8) value) :start (1+ name-len)))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) + (values (and (plusp (length name)) (map 'string #'card8->char name)) + (and (plusp (length class)) (map 'string #'card8->char class))))))) (defun set-wm-class (window resource-name resource-class) (declare (type window window) - (type (or null stringable) resource-name resource-class)) + (type (or null stringable) resource-name resource-class)) (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) + (concatenate '(vector card8) + (map '(vector card8) #'char->card8 + (string (or resource-name ""))) + #(0) + (map '(vector card8) #'char->card8 + (string (or resource-class ""))) + #(0)) + :string 8) (values)) (defun wm-command (window) @@ -88,15 +88,15 @@ (declare (type window window)) (declare (clx-values list)) (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) + :result-type '(vector card8))) + (command nil) + (start 0 (1+ end)) + (end 0) + (len (length command-string))) ((>= start len) (nreverse command)) (setq end (position 0 command-string :start start)) (push (map 'string #'card8->char (subseq command-string start end)) - command))) + command))) (defsetf wm-command set-wm-command) (defun set-wm-command (window command) @@ -106,17 +106,17 @@ ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) ;; to recover a lisp command. (declare (type window window) - (type list command)) + (type list command)) (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) + (apply #'concatenate '(vector card8) + (mapcan #'(lambda (c) + (list (map '(vector card8) #'char->card8 + (with-output-to-string (stream) + (with-standard-io-syntax + (prin1 c stream)))) + #(0))) + command)) + :string 8) command) ;;----------------------------------------------------------------------------- @@ -145,46 +145,46 @@ (defsetf wm-hints set-wm-hints) (defun set-wm-hints (window wm-hints) (declare (type window window) - (type wm-hints wm-hints)) + (type wm-hints wm-hints)) (declare (clx-values wm-hints)) (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) wm-hints) (defun decode-wm-hints (vector display) (declare (type (simple-vector 9) vector) - (type display display)) + (type display display)) (declare (clx-values wm-hints)) (let ((input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) + (state-hint 1) + (icon-pixmap-hint 2) + (icon-window-hint 3) + (icon-position-hint 4) + (icon-mask-hint 5) + (window-group-hint 6)) (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) + (hints (make-wm-hints)) + (%buffer display)) (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) + (type wm-hints hints) + (type display %buffer)) (setf (wm-hints-flags hints) flags) (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) + (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) + (setf (wm-hints-initial-state hints) + (decode-type (member :dont-care :normal :zoom :iconic :inactive) + (aref vector 2)))) (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) + (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) + (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (aref vector 5) - (wm-hints-icon-y hints) (aref vector 6))) + (setf (wm-hints-icon-x hints) (aref vector 5) + (wm-hints-icon-y hints) (aref vector 6))) (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) + (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (aref vector 8))) + (setf (wm-hints-window-group hints) (aref vector 8))) hints))) @@ -192,41 +192,41 @@ (declare (type wm-hints wm-hints)) (declare (clx-values simple-vector)) (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) + (state-hint #b10) + (icon-pixmap-hint #b100) + (icon-window-hint #b1000) + (icon-position-hint #b10000) + (icon-mask-hint #b100000) + (window-group-hint #b1000000) + (mask #b1111111) + ) (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) + (flags 0)) (declare (type (simple-vector 9) vector) - (type card16 flags)) + (type card16 flags)) (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) + (setf flags input-hint + (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) + (setf flags (logior flags state-hint) + (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) + (wm-hints-initial-state wm-hints)))) (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) + (setf flags (logior flags icon-pixmap-hint) + (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) + (setf flags (logior flags icon-window-hint) + (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) + (setf flags (logior flags icon-position-hint) + (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) + (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) + (setf flags (logior flags icon-mask-hint) + (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) + (setf flags (logior flags window-group-hint) + (aref vector 8) (wm-hints-window-group wm-hints))) (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) vector))) @@ -267,7 +267,7 @@ (defsetf wm-normal-hints set-wm-normal-hints) (defun set-wm-normal-hints (window hints) (declare (type window window) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) @@ -283,7 +283,7 @@ ;;; OBSOLETE (defun set-wm-zoom-hints (window hints) (declare (type window window) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) @@ -293,50 +293,50 @@ (declare (clx-values (or null wm-size-hints))) (when vector (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) + (hints (make-wm-size-hints))) (declare (type card16 flags) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) + (setf (wm-size-hints-min-width hints) (aref vector 5) + (wm-size-hints-min-height hints) (aref vector 6))) (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) + (setf (wm-size-hints-max-width hints) (aref vector 7) + (wm-size-hints-max-height hints) (aref vector 8))) (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) + (setf (wm-size-hints-width-inc hints) (aref vector 9) + (wm-size-hints-height-inc hints) (aref vector 10))) (when (logbitp 7 flags) - (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) - (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) + (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) + (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) + ;; This test is for backwards compatibility since old Xlib programs + ;; can set a size-hints structure that is too small. See ICCCM. + (when (logbitp 8 flags) + (setf (wm-size-hints-base-width hints) (aref vector 15) + (wm-size-hints-base-height hints) (aref vector 16))) + (when (logbitp 9 flags) + (setf (wm-size-hints-win-gravity hints) + (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) - (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) + (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) + (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) + (setf (wm-size-hints-width hints) (aref vector 3) + (wm-size-hints-height hints) (aref vector 4))) hints))) (defun encode-wm-size-hints (hints) (declare (type wm-size-hints hints)) (declare (clx-values simple-vector)) (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) + (flags 0)) (declare (type (simple-vector 18) vector) - (type card16 flags)) + (type card16 flags)) (when (wm-size-hints-user-specified-position-p hints) (setf (ldb (byte 1 0) flags) 1)) (when (wm-size-hints-user-specified-size-p hints) @@ -347,47 +347,47 @@ (setf (ldb (byte 1 3) flags) 1)) (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) + (aref vector 5) (wm-size-hints-min-width hints) + (aref vector 6) (wm-size-hints-min-height hints))) (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) + (aref vector 7) (wm-size-hints-max-width hints) + (aref vector 8) (wm-size-hints-max-height hints))) (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) + (aref vector 9) (wm-size-hints-width-inc hints) + (aref vector 10) (wm-size-hints-height-inc hints))) (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) + (max-aspect (wm-size-hints-max-aspect hints))) (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) + (setf (ldb (byte 1 7) flags) 1 + min-aspect (rationalize min-aspect) + max-aspect (rationalize max-aspect) + (aref vector 11) (numerator min-aspect) + (aref vector 12) (denominator min-aspect) + (aref vector 13) (numerator max-aspect) + (aref vector 14) (denominator max-aspect)))) (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) + (wm-size-hints-base-height hints)) (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) + (aref vector 15) (wm-size-hints-base-width hints) + (aref vector 16) (wm-size-hints-base-height hints))) (when (wm-size-hints-win-gravity hints) (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector +win-gravity-vector+) - (wm-size-hints-win-gravity hints)))) + (aref vector 17) (encode-type + (member-vector +win-gravity-vector+) + (wm-size-hints-win-gravity hints)))) ;; Obsolete fields (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) + (setf (ldb (byte 1 2) flags) 1)) (setf (aref vector 1) (wm-size-hints-x hints) - (aref vector 2) (wm-size-hints-y hints))) + (aref vector 2) (wm-size-hints-y hints))) (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) + (setf (ldb (byte 1 3) flags) 1)) (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) + (aref vector 4) (wm-size-hints-height hints))) (setf (aref vector 0) flags) vector)) @@ -403,23 +403,23 @@ (declare (type (or null (simple-vector 6)) vector)) (when vector (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) + :min-width (aref vector 0) + :min-height (aref vector 1) + :max-width (aref vector 2) + :max-height (aref vector 3) + :width-inc (aref vector 4) + :height-inc (aref vector 5))))) (defsetf icon-sizes set-icon-sizes) (defun set-icon-sizes (window wm-size-hints) (declare (type window window) - (type wm-size-hints wm-size-hints)) + (type wm-size-hints wm-size-hints)) (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) + (wm-size-hints-min-height wm-size-hints) + (wm-size-hints-max-width wm-size-hints) + (wm-size-hints-max-height wm-size-hints) + (wm-size-hints-width-inc wm-size-hints) + (wm-size-hints-height-inc wm-size-hints)))) (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) wm-size-hints)) @@ -433,9 +433,9 @@ (defsetf wm-protocols set-wm-protocols) (defun set-wm-protocols (window protocols) (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) + (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) + protocols) + :ATOM 32) protocols) ;;----------------------------------------------------------------------------- @@ -443,13 +443,13 @@ (defun wm-colormap-windows (window) (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) + :transform #'(lambda (id) + (lookup-window (window-display window) id))))) (defsetf wm-colormap-windows set-wm-colormap-windows) (defun set-wm-colormap-windows (window colormap-windows) (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) + :transform #'window-id) colormap-windows) ;;----------------------------------------------------------------------------- @@ -469,50 +469,50 @@ ;; Set-WM-Properties (defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) + name icon-name resource-name resource-class command + client-machine hints normal-hints zoom-hints + ;; the following are used for wm-normal-hints + (user-specified-position-p nil usppp) + (user-specified-size-p nil usspp) + (program-specified-position-p nil psppp) + (program-specified-size-p nil psspp) + x y width height min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group) ;; Set properties for WINDOW. (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) + name icon-name resource-name resource-class command + client-machine hints normal-hints + ;; the following are used for wm-normal-hints + user-specified-position-p user-specified-size-p + program-specified-position-p program-specified-size-p + min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group)) (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type generalized-boolean user-specified-position-p user-specified-size-p) - (type generalized-boolean program-specified-position-p program-specified-size-p) - (type (or null int32) x y) - (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card32) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) + (type (or null stringable) name icon-name resource-name resource-class client-machine) + (type (or null list) command) + (type (or null wm-hints) hints) + (type (or null wm-size-hints) normal-hints zoom-hints) + (type generalized-boolean user-specified-position-p user-specified-size-p) + (type generalized-boolean program-specified-position-p program-specified-size-p) + (type (or null int32) x y) + (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) + (type (or null win-gravity) win-gravity) + (type (or null number) min-aspect max-aspect) + (type (or null (member :off :on)) input) + (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) + (type (or null pixmap) icon-pixmap icon-mask) + (type (or null window) icon-window) + (type (or null card32) icon-x icon-y) + (type (or null resource-id) window-group) + (dynamic-extent options)) (when name (setf (wm-name window) name)) (when icon-name (setf (wm-icon-name window) icon-name)) (when client-machine (setf (wm-client-machine window) client-machine)) @@ -521,51 +521,51 @@ (when command (setf (wm-command window) command)) ;; WM-HINTS (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) + :icon-x :icon-y :icon-mask :window-group)) + (when (getf options arg) (return t))) (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) + (when input (setf (wm-hints-input wm-hints) input)) + (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) + (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) + (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) + (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) + (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) + (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) + (when window-group (setf (wm-hints-window-group wm-hints) window-group)) + (setf (wm-hints window) wm-hints)) (when hints (setf (wm-hints window) hints))) ;; WM-NORMAL-HINTS (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) + :width-inc :height-inc :min-aspect :max-aspect + :user-specified-position-p :user-specified-size-p + :program-specified-position-p :program-specified-size-p + :base-width :base-height :win-gravity)) + (when (getf options arg) (return t))) (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) + (when x (setf (wm-size-hints-x size) x)) + (when y (setf (wm-size-hints-y size) y)) + (when width (setf (wm-size-hints-width size) width)) + (when height (setf (wm-size-hints-height size) height)) + (when min-width (setf (wm-size-hints-min-width size) min-width)) + (when min-height (setf (wm-size-hints-min-height size) min-height)) + (when max-width (setf (wm-size-hints-max-width size) max-width)) + (when max-height (setf (wm-size-hints-max-height size) max-height)) + (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) + (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) + (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) + (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) + (when base-width (setf (wm-size-hints-base-width size) base-width)) + (when base-height (setf (wm-size-hints-base-height size) base-height)) + (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) + (when usppp + (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) + (when usspp + (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) + (when psppp + (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) + (when psspp + (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) + (setf (wm-normal-hints window) size)) (when normal-hints (setf (wm-normal-hints window) normal-hints))) (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) ) @@ -580,20 +580,20 @@ (defun iconify-window (window screen) (declare (type window window) - (type screen screen)) + (type screen screen)) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) + :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) (defun withdraw-window (window screen) (declare (type window window) - (type screen screen)) + (type screen screen)) (unmap-window window) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) + :window window :event-window root :configure-p nil))) ;;----------------------------------------------------------------------------- @@ -606,150 +606,150 @@ (mult-color nil :type (or null color)) (visual nil :type (or null visual-info)) (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) + drawable gcontext cursor colormap font))) (defun rgb-colormaps (window property) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) + :colormap (lookup-colormap (window-display window) (aref prop 0)) + :base-pixel (aref prop 7) + :max-color (make-color :red (card16->rgb-val (aref prop 1)) + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + :mult-color (make-color :red (card16->rgb-val (aref prop 2)) + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))) + :visual (and (<= 9 (length prop)) + (visual-info (window-display window) (aref prop 8))) + :kill (and (<= 10 (length prop)) + (let ((killid (aref prop 9))) + (if (= killid 1) + :release-by-freeing-colormap + (lookup-resource-id (window-display window) killid))))))))) (defsetf rgb-colormaps set-rgb-colormaps) (defun set-rgb-colormaps (window property maps) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property) + (type list maps)) (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) + (index -1)) (dolist (map maps) (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) + (encode-type colormap (standard-colormap-colormap map))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) + (encode-type rgb-val (color-red (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) + (encode-type rgb-val (color-green (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) + (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) + (standard-colormap-base-pixel map)) (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) + (visual-info-id (standard-colormap-visual map))) (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) + (let ((kill (standard-colormap-kill map))) + (etypecase kill + (symbol + (ecase kill + ((nil) 0) + ((:release-by-freeing-colormap) 1))) + (drawable (drawable-id kill)) + (gcontext (gcontext-id kill)) + (cursor (cursor-id kill)) + (colormap (colormap-id kill)) + (font (font-id kill)))))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;; OBSOLETE (defun get-standard-colormap (window property) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (declare (clx-values colormap base-pixel max-color mult-color)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) + (aref prop 7) ;Base Pixel + (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))))))) ;;; OBSOLETE (defun set-standard-colormap (window property colormap base-pixel max-color mult-color) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property) + (type colormap colormap) + (type pixel base-pixel) + (type color max-color mult-color)) (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) + (encode-type rgb-val (color-red max-color)) + (encode-type rgb-val (color-red mult-color)) + (encode-type rgb-val (color-green max-color)) + (encode-type rgb-val (color-green mult-color)) + (encode-type rgb-val (color-blue max-color)) + (encode-type rgb-val (color-blue mult-color)) + base-pixel))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;----------------------------------------------------------------------------- ;; Cut-Buffers (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) + (transform #'card8->char) (start 0) end) ;; Return the contents of cut-buffer BUFFER (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) + (type (integer 0 7) buffer) + (type xatom type) + (type array-index start) + (type (or null array-index) end) + (type t result-type) ;a sequence type + (type (or null (function (integer) t)) transform)) (declare (clx-values sequence type format bytes-after)) (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) + :start start :end end :transform transform))) ;; Implement the following: ;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) +;; (transform #'char->card8) (start 0) end) (data) ;; In order to avoid having to pass positional parameters to set-cut-buffer, ;; We've got to do the following. WHAT A PAIN... #-clx-ansi-common-lisp (define-setf-method cut-buffer (display &rest option-list) (declare (dynamic-extent option-list)) (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) + (option options (cddr option)) + (store (gensym)) + (dtemp (gensym)) + (temps (list dtemp)) + (values (list display))) ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) + (values (nreverse temps) + (nreverse values) + (list store) + `(set-cut-buffer ,store ,dtemp ,@options) + `(cut-buffer ,@options))) (unless (member (car option) '(:buffer :type :format :start :end :transform)) (error "Keyword arg ~s isn't recognized" (car option))) (let ((x (gensym))) @@ -761,19 +761,19 @@ #+clx-ansi-common-lisp (setf cut-buffer) #-clx-ansi-common-lisp set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) + (start 0) end (transform #'char->card8)) (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) + (type display display) + (type (integer 0 7) buffer) + (type xatom type) + (type (member 8 16 32) format) + (type array-index start) + (type (or null array-index) end) + (type (or null (function (integer) t)) transform)) (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) (change-property root property data type format :transform transform :start start :end end) data)) @@ -781,15 +781,15 @@ ;; Positive rotates left, negative rotates right (opposite of actual protocol request). ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. (declare (type display display) - (type int16 delta) - (type generalized-boolean careful-p)) + (type int16 delta) + (type generalized-boolean careful-p)) (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) + (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 + :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) (when careful-p (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) + (dotimes (i 8) + (unless (member (aref buffers i) props) + (setf (cut-buffer display :buffer i) ""))))) (rotate-properties root buffers delta))) diff --git a/src/clx/provide.lisp b/src/clx/provide.lisp index bf6f3c7a4..7fd0daf3e 100644 --- a/src/clx/provide.lisp +++ b/src/clx/provide.lisp @@ -8,10 +8,10 @@ ;;; Ideally, this file (or a file that loads this file) should be ;;; located in the system directory that REQUIRE searches. Thus a user ;;; would say -;;; (require :clx) +;;; (require :clx) ;;; to load CLX. If there is no such registry, then the user must ;;; put in a site specific -;;; (require :clx ) +;;; (require :clx ) ;;; #-clx-ansi-common-lisp @@ -24,30 +24,30 @@ (provide :clx) (defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) + (pathname "/src/local/clx/*.l")) (defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) + (let ((lisp + (or #+lucid "lucid" + #+akcl "akcl" + #+kcl "kcl" + #+ibcl "ibcl" + (error "Can't provide CLX for this lisp."))) + (architecture + (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" + #+(or sun4 sparc) "sparc" + #+(and hp (or mc68000 mc68020)) "hp9000s300" + #+vax "vax" + #+prime "prime" + #+sunrise "sunrise" + #+ibm-rt-pc "ibm-rt-pc" + #+mips "mips" + #+prism "prism" + (error "Can't provide CLX for this architecture.")))) + (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) (defvar *compile-clx* - nil) + nil) (load (merge-pathnames "defsystem" *clx-source-pathname*)) diff --git a/src/clx/requests.lisp b/src/clx/requests.lisp index 745414cd9..e554d8dbc 100644 --- a/src/clx/requests.lisp +++ b/src/clx/requests.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -19,51 +19,51 @@ (in-package :xlib) (defun create-window (&key - window - (parent (required-arg parent)) - (x (required-arg x)) - (y (required-arg y)) - (width (required-arg width)) - (height (required-arg height)) - (depth 0) (border-width 0) - (class :copy) (visual :copy) - background border - bit-gravity gravity - backing-store backing-planes backing-pixel save-under - event-mask do-not-propagate-mask override-redirect - colormap cursor) + window + (parent (required-arg parent)) + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + (depth 0) (border-width 0) + (class :copy) (visual :copy) + background border + bit-gravity gravity + backing-store backing-planes backing-pixel save-under + event-mask do-not-propagate-mask override-redirect + colormap cursor) ;; Display is obtained from parent. Only non-nil attributes are passed on in ;; the request: the function makes no assumptions about what the actual protocol ;; defaults are. Width and height are the inside size, excluding border. (declare (type (or null window) window) - (type window parent) ; required - (type int16 x y) ;required - (type card16 width height) ;required - (type card16 depth border-width) - (type (member :copy :input-output :input-only) class) - (type (or (member :copy) visual-info resource-id) visual) - (type (or null (member :none :parent-relative) pixel pixmap) background) - (type (or null (member :copy) pixel pixmap) border) - (type (or null bit-gravity) bit-gravity) - (type (or null win-gravity) gravity) - (type (or null (member :not-useful :when-mapped :always)) backing-store) - (type (or null pixel) backing-planes backing-pixel) - (type (or null event-mask) event-mask) - (type (or null device-event-mask) do-not-propagate-mask) - (type (or null (member :on :off)) save-under override-redirect) - (type (or null (member :copy) colormap) colormap) - (type (or null (member :none) cursor) cursor)) + (type window parent) ; required + (type int16 x y) ;required + (type card16 width height) ;required + (type card16 depth border-width) + (type (member :copy :input-output :input-only) class) + (type (or (member :copy) visual-info resource-id) visual) + (type (or null (member :none :parent-relative) pixel pixmap) background) + (type (or null (member :copy) pixel pixmap) border) + (type (or null bit-gravity) bit-gravity) + (type (or null win-gravity) gravity) + (type (or null (member :not-useful :when-mapped :always)) backing-store) + (type (or null pixel) backing-planes backing-pixel) + (type (or null event-mask) event-mask) + (type (or null device-event-mask) do-not-propagate-mask) + (type (or null (member :on :off)) save-under override-redirect) + (type (or null (member :copy) colormap) colormap) + (type (or null (member :none) cursor) cursor)) (declare (clx-values window)) (let* ((display (window-display parent)) - (window (or window (make-window :display display))) - (wid (allocate-resource-id display window 'window)) - back-pixmap back-pixel - border-pixmap border-pixel) + (window (or window (make-window :display display))) + (wid (allocate-resource-id display window 'window)) + back-pixmap back-pixel + border-pixmap border-pixel) (declare (type display display) - (type window window) - (type resource-id wid) - (type (or null resource-id) back-pixmap border-pixmap) - (type (or null pixel) back-pixel border-pixel)) + (type window window) + (type resource-id wid) + (type (or null resource-id) back-pixmap border-pixmap) + (type (or null pixel) back-pixel border-pixel)) (setf (window-id window) wid) (case background ((nil) nil) @@ -71,26 +71,26 @@ (:parent-relative (setq back-pixmap 1)) (otherwise (if (type? background 'pixmap) - (setq back-pixmap (pixmap-id background)) - (if (integerp background) - (setq back-pixel background) - (x-type-error background - '(or null (member :none :parent-relative) integer pixmap)))))) + (setq back-pixmap (pixmap-id background)) + (if (integerp background) + (setq back-pixel background) + (x-type-error background + '(or null (member :none :parent-relative) integer pixmap)))))) (case border ((nil) nil) (:copy (setq border-pixmap 0)) (otherwise (if (type? border 'pixmap) - (setq border-pixmap (pixmap-id border)) - (if (integerp border) - (setq border-pixel border) - (x-type-error border '(or null (member :copy) integer pixmap)))))) + (setq border-pixmap (pixmap-id border)) + (if (integerp border) + (setq border-pixel border) + (x-type-error border '(or null (member :copy) integer pixmap)))))) (when event-mask (setq event-mask (encode-event-mask event-mask))) (when do-not-propagate-mask (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) - ;Make the request + ;Make the request (with-buffer-request (display +x-createwindow+) (data depth) (resource-id wid) @@ -99,20 +99,20 @@ (card16 width height border-width) ((member16 :copy :input-output :input-only) class) (resource-id (cond ((eq visual :copy) - 0) - ((typep visual 'resource-id) - visual) - (t - (visual-info-id visual)))) + 0) + ((typep visual 'resource-id) + visual) + (t + (visual-info-id visual)))) (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) - ((member-vector +bit-gravity-vector+) bit-gravity) - ((member-vector +win-gravity-vector+) gravity) - ((member :not-useful :when-mapped :always) backing-store) - (card32 backing-planes backing-pixel) - ((member :off :on) override-redirect save-under) - (card32 event-mask do-not-propagate-mask) - ((or (member :copy) colormap) colormap) - ((or (member :none) cursor) cursor))) + ((member-vector +bit-gravity-vector+) bit-gravity) + ((member-vector +win-gravity-vector+) gravity) + ((member :not-useful :when-mapped :always) backing-store) + (card32 backing-planes backing-pixel) + ((member :off :on) override-redirect save-under) + (card32 event-mask do-not-propagate-mask) + ((or (member :copy) colormap) colormap) + ((or (member :none) cursor) cursor))) window)) (defun destroy-window (window) @@ -139,7 +139,7 @@ (defun reparent-window (window parent x y) (declare (type window window parent) - (type int16 x y)) + (type int16 x y)) (with-buffer-request ((window-display window) +x-reparentwindow+) (window window parent) (int16 x y))) @@ -178,21 +178,21 @@ (defun query-tree (window &key (result-type 'list)) (declare (type window window) - (type t result-type)) ;;type specifier + (type t result-type)) ;;type specifier (declare (clx-values (clx-sequence window) parent root)) (let ((display (window-display window))) (multiple-value-bind (root parent sequence) - (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) - ((window window)) - (values - (window-get 8) - (resource-id-get 12) - (sequence-get :length (card16-get 16) :result-type result-type - :index +replysize+))) + (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) + ((window window)) + (values + (window-get 8) + (resource-id-get 12) + (sequence-get :length (card16-get 16) :result-type result-type + :index +replysize+))) ;; Parent is NIL for root window (setq parent (and (plusp parent) (lookup-window display parent))) - (dotimes (i (length sequence)) ; Convert ID's to window's - (setf (elt sequence i) (lookup-window display (elt sequence i)))) + (dotimes (i (length sequence)) ; Convert ID's to window's + (setf (elt sequence i) (lookup-window display (elt sequence i)))) (values sequence parent root)))) ;; Although atom-ids are not visible in the normal user interface, atom-ids might @@ -200,96 +200,96 @@ (defun intern-atom (display name) (declare (type display display) - (type xatom name)) + (type xatom name)) (declare (clx-values resource-id)) (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) + name + (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 0) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (resource-id-get 8))) - (declare (type resource-id id)) - (setf (atom-id name display) id) - id))))) + (let ((string (symbol-name name))) + (declare (type string string)) + (multiple-value-bind (id) + (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) + ((data 0) + (card16 (length string)) + (pad16 nil) + (string string)) + (values + (resource-id-get 8))) + (declare (type resource-id id)) + (setf (atom-id name display) id) + id))))) (defun find-atom (display name) ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True (declare (type display display) - (type xatom name)) + (type xatom name)) (declare (clx-values (or null resource-id))) (let ((name (if (or (null name) (keywordp name)) - name - (kintern (string name))))) + name + (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) - (let ((string (symbol-name name))) - (declare (type string string)) - (multiple-value-bind (id) - (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) - ((data 1) - (card16 (length string)) - (pad16 nil) - (string string)) - (values - (or-get 8 null resource-id))) - (declare (type (or null resource-id) id)) - (when id - (setf (atom-id name display) id)) - id))))) + (let ((string (symbol-name name))) + (declare (type string string)) + (multiple-value-bind (id) + (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) + ((data 1) + (card16 (length string)) + (pad16 nil) + (string string)) + (values + (or-get 8 null resource-id))) + (declare (type (or null resource-id) id)) + (when id + (setf (atom-id name display) id)) + id))))) (defun atom-name (display atom-id) (declare (type display display) - (type resource-id atom-id)) + (type resource-id atom-id)) (declare (clx-values keyword)) (if (zerop atom-id) nil (or (id-atom atom-id display) (let ((keyword - (kintern - (with-buffer-request-and-reply - (display +x-getatomname+ nil :sizes (16)) - ((resource-id atom-id)) - (values - (string-get (card16-get 8) +replysize+)))))) - (declare (type keyword keyword)) - (setf (atom-id keyword display) atom-id) - keyword)))) + (kintern + (with-buffer-request-and-reply + (display +x-getatomname+ nil :sizes (16)) + ((resource-id atom-id)) + (values + (string-get (card16-get 8) +replysize+)))))) + (declare (type keyword keyword)) + (setf (atom-id keyword display) atom-id) + keyword)))) ;;; For binary compatibility with older code (defun lookup-xatom (display atom-id) (declare (type display display) - (type resource-id atom-id)) + (type resource-id atom-id)) (atom-name display atom-id)) (defun change-property (window property data type format - &key (mode :replace) (start 0) end transform) + &key (mode :replace) (start 0) end transform) ; Start and end affect sub-sequence extracted from data. ; Transform is applied to each extracted element. (declare (type window window) - (type xatom property type) - (type (member 8 16 32) format) - (type sequence data) - (type (member :replace :prepend :append) mode) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (t) integer)) transform)) + (type xatom property type) + (type (member 8 16 32) format) + (type sequence data) + (type (member :replace :prepend :append) mode) + (type array-index start) + (type (or null array-index) end) + (type (or null (function (t) integer)) transform)) (unless end (setq end (length data))) (let* ((display (window-display window)) - (length (index- end start)) - (property-id (intern-atom display property)) - (type-id (intern-atom display type))) + (length (index- end start)) + (property-id (intern-atom display property)) + (type-id (intern-atom display type))) (declare (type display display) - (type array-index length) - (type resource-id property-id type-id)) + (type array-index length) + (type resource-id property-id type-id)) (with-buffer-request (display +x-changeproperty+) ((data (member :replace :prepend :append)) mode) (window window) @@ -297,135 +297,135 @@ (card8 format) (card32 length) (progn - (ecase format - (8 (sequence-put 24 data :format card8 - :start start :end end :transform transform)) - (16 (sequence-put 24 data :format card16 - :start start :end end :transform transform)) - (32 (sequence-put 24 data :format card32 - :start start :end end :transform transform))))))) + (ecase format + (8 (sequence-put 24 data :format card8 + :start start :end end :transform transform)) + (16 (sequence-put 24 data :format card16 + :start start :end end :transform transform)) + (32 (sequence-put 24 data :format card32 + :start start :end end :transform transform))))))) (defun delete-property (window property) (declare (type window window) - (type xatom property)) + (type xatom property)) (let* ((display (window-display window)) - (property-id (intern-atom display property))) + (property-id (intern-atom display property))) (declare (type display display) - (type resource-id property-id)) + (type resource-id property-id)) (with-buffer-request (display +x-deleteproperty+) (window window) (resource-id property-id)))) (defun get-property (window property - &key type (start 0) end delete-p (result-type 'list) transform) + &key type (start 0) end delete-p (result-type 'list) transform) ;; Transform is applied to each integer retrieved. (declare (type window window) - (type xatom property) - (type (or null xatom) type) - (type array-index start) - (type (or null array-index) end) - (type generalized-boolean delete-p) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) + (type xatom property) + (type (or null xatom) type) + (type array-index start) + (type (or null array-index) end) + (type generalized-boolean delete-p) + (type t result-type) ;a sequence type + (type (or null (function (integer) t)) transform)) (declare (clx-values data (or null type) format bytes-after)) (let* ((display (window-display window)) - (property-id (intern-atom display property)) - (type-id (and type (intern-atom display type)))) + (property-id (intern-atom display property)) + (type-id (and type (intern-atom display type)))) (declare (type display display) - (type resource-id property-id) - (type (or null resource-id) type-id)) + (type resource-id property-id) + (type (or null resource-id) type-id)) (multiple-value-bind (reply-format reply-type bytes-after data) - (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) - (((data boolean) delete-p) - (window window) - (resource-id property-id) - ((or null resource-id) type-id) - (card32 start) - (card32 (index- (or end 64000) start))) - (let ((reply-format (card8-get 1)) - (reply-type (card32-get 8)) - (bytes-after (card32-get 12)) - (nitems (card32-get 16))) - (values - reply-format - reply-type - bytes-after - (and (plusp nitems) - (ecase reply-format - (0 nil) ;; (make-sequence result-type 0) ;; Property not found. - (8 (sequence-get :result-type result-type :format card8 - :length nitems :transform transform - :index +replysize+)) - (16 (sequence-get :result-type result-type :format card16 - :length nitems :transform transform - :index +replysize+)) - (32 (sequence-get :result-type result-type :format card32 - :length nitems :transform transform - :index +replysize+))))))) + (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) + (((data boolean) delete-p) + (window window) + (resource-id property-id) + ((or null resource-id) type-id) + (card32 start) + (card32 (index- (or end 64000) start))) + (let ((reply-format (card8-get 1)) + (reply-type (card32-get 8)) + (bytes-after (card32-get 12)) + (nitems (card32-get 16))) + (values + reply-format + reply-type + bytes-after + (and (plusp nitems) + (ecase reply-format + (0 nil) ;; (make-sequence result-type 0) ;; Property not found. + (8 (sequence-get :result-type result-type :format card8 + :length nitems :transform transform + :index +replysize+)) + (16 (sequence-get :result-type result-type :format card16 + :length nitems :transform transform + :index +replysize+)) + (32 (sequence-get :result-type result-type :format card32 + :length nitems :transform transform + :index +replysize+))))))) (values data - (and (plusp reply-type) (atom-name display reply-type)) - reply-format - bytes-after)))) + (and (plusp reply-type) (atom-name display reply-type)) + reply-format + bytes-after)))) (defun rotate-properties (window properties &optional (delta 1)) ;; Positive rotates left, negative rotates right (opposite of actual protocol request). (declare (type window window) - (type sequence properties) ;; sequence of xatom - (type int16 delta)) + (type sequence properties) ;; sequence of xatom + (type int16 delta)) (let* ((display (window-display window)) - (length (length properties)) - (sequence (make-array length))) + (length (length properties)) + (sequence (make-array length))) (declare (type display display) - (type array-index length)) + (type array-index length)) (with-vector (sequence vector) ;; Atoms must be interned before the RotateProperties request ;; is started to allow InternAtom requests to be made. (dotimes (i length) - (setf (aref sequence i) (intern-atom display (elt properties i)))) + (setf (aref sequence i) (intern-atom display (elt properties i)))) (with-buffer-request (display +x-rotateproperties+) - (window window) - (card16 length) - (int16 (- delta)) - ((sequence :end length) sequence)))) + (window window) + (card16 length) + (int16 (- delta)) + ((sequence :end length) sequence)))) nil) (defun list-properties (window &key (result-type 'list)) (declare (type window window) - (type t result-type)) ;; a sequence type + (type t result-type)) ;; a sequence type (declare (clx-values (clx-sequence keyword))) (let ((display (window-display window))) (multiple-value-bind (seq) - (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :index +replysize+))) + (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) + ((window window)) + (values + (sequence-get :result-type result-type :length (card16-get 8) + :index +replysize+))) ;; lookup the atoms in the sequence (if (listp seq) - (do ((elt seq (cdr elt))) - ((endp elt) seq) - (setf (car elt) (atom-name display (car elt)))) - (dotimes (i (length seq) seq) - (setf (aref seq i) (atom-name display (aref seq i)))))))) + (do ((elt seq (cdr elt))) + ((endp elt) seq) + (setf (car elt) (atom-name display (car elt)))) + (dotimes (i (length seq) seq) + (setf (aref seq i) (atom-name display (aref seq i)))))))) (defun selection-owner (display selection) (declare (type display display) - (type xatom selection)) + (type xatom selection)) (declare (clx-values (or null window))) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (multiple-value-bind (window) - (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) - ((resource-id selection-id)) - (values - (resource-id-or-nil-get 8))) + (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) + ((resource-id selection-id)) + (values + (resource-id-or-nil-get 8))) (and window (lookup-window display window))))) (defun set-selection-owner (display selection owner &optional time) (declare (type display display) - (type xatom selection) - (type (or null window) owner) - (type timestamp time)) + (type xatom selection) + (type (or null window) owner) + (type timestamp time)) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (with-buffer-request (display +x-setselectionowner+) @@ -440,16 +440,16 @@ (defun convert-selection (selection type requestor &optional property time) (declare (type xatom selection type) - (type window requestor) - (type (or null xatom) property) - (type timestamp time)) + (type window requestor) + (type (or null xatom) property) + (type timestamp time)) (let* ((display (window-display requestor)) - (selection-id (intern-atom display selection)) - (type-id (intern-atom display type)) - (property-id (and property (intern-atom display property)))) + (selection-id (intern-atom display selection)) + (type-id (intern-atom display type)) + (property-id (and property (intern-atom display property)))) (declare (type display display) - (type resource-id selection-id type-id) - (type (or null resource-id) property-id)) + (type resource-id selection-id type-id) + (type (or null resource-id) property-id)) (with-buffer-request (display +x-convertselection+) (window requestor) (resource-id selection-id type-id) @@ -457,31 +457,31 @@ ((or null card32) time)))) (defun send-event (window event-key event-mask &rest args - &key propagate-p display &allow-other-keys) + &key propagate-p display &allow-other-keys) ;; Additional arguments depend on event-key, and are as specified further below ;; with declare-event, except that both resource-ids and resource objects are ;; accepted in the event components. The display argument is only required if the ;; window is :pointer-window or :input-focus. (declare (type (or window (member :pointer-window :input-focus)) window) - (type event-key event-key) - (type (or null event-mask) event-mask) - (type generalized-boolean propagate-p) - (type (or null display) display) - (dynamic-extent args)) + (type event-key event-key) + (type (or null event-mask) event-mask) + (type generalized-boolean propagate-p) + (type (or null display) display) + (dynamic-extent args)) (unless event-mask (setq event-mask 0)) (unless display (setq display (window-display window))) (let ((internal-event-code (get-event-code event-key)) - (external-event-code (get-external-event-code display event-key))) + (external-event-code (get-external-event-code display event-key))) (declare (type card8 internal-event-code external-event-code)) ;; Ensure keyword atom-id's are cached (dolist (arg (cdr (assoc event-key '((:property-notify :atom) - (:selection-clear :selection) - (:selection-request :selection :target :property) - (:selection-notify :selection :target :property) - (:client-message :type)) - :test #'eq))) + (:selection-clear :selection) + (:selection-request :selection :target :property) + (:selection-notify :selection :target :property) + (:client-message :type)) + :test #'eq))) (let ((keyword (getf args arg))) - (intern-atom display keyword))) + (intern-atom display keyword))) ;; Make the sendevent request (with-buffer-request (display +x-sendevent+) ((data boolean) propagate-p) @@ -490,29 +490,29 @@ (card32 (encode-event-mask event-mask)) (card8 external-event-code) (progn - (apply (svref *event-send-vector* internal-event-code) display args) - (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) + (apply (svref *event-send-vector* internal-event-code) display args) + (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) (defun grab-pointer (window event-mask - &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) + &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) (declare (type window window) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor) - (type timestamp time)) + (type pointer-event-mask event-mask) + (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) + (type (or null window) confine-to) + (type (or null cursor) cursor) + (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - (card16 (encode-pointer-event-mask event-mask)) - (boolean (not sync-pointer-p) (not sync-keyboard-p)) - ((or null window) confine-to) - ((or null cursor) cursor) - ((or null card32) time)) + (((data boolean) owner-p) + (window window) + (card16 (encode-pointer-event-mask event-mask)) + (boolean (not sync-pointer-p) (not sync-keyboard-p)) + ((or null window) confine-to) + ((or null cursor) cursor) + ((or null card32) time)) (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) + (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-pointer (display &key time) (declare (type timestamp time)) @@ -520,15 +520,15 @@ ((or null card32) time))) (defun grab-button (window button event-mask - &key (modifiers :any) - owner-p sync-pointer-p sync-keyboard-p confine-to cursor) + &key (modifiers :any) + owner-p sync-pointer-p sync-keyboard-p confine-to cursor) (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers) - (type pointer-event-mask event-mask) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or null window) confine-to) - (type (or null cursor) cursor)) + (type (or (member :any) card8) button) + (type modifier-mask modifiers) + (type pointer-event-mask event-mask) + (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) + (type (or null window) confine-to) + (type (or null cursor) cursor)) (with-buffer-request ((window-display window) +x-grabbutton+) ((data boolean) owner-p) (window window) @@ -542,8 +542,8 @@ (defun ungrab-button (window button &key (modifiers :any)) (declare (type window window) - (type (or (member :any) card8) button) - (type modifier-mask modifiers)) + (type (or (member :any) card8) button) + (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabbutton+) (data (if (eq button :any) 0 button)) (window window) @@ -551,9 +551,9 @@ (defun change-active-pointer-grab (display event-mask &optional cursor time) (declare (type display display) - (type pointer-event-mask event-mask) - (type (or null cursor) cursor) - (type timestamp time)) + (type pointer-event-mask event-mask) + (type (or null cursor) cursor) + (type timestamp time)) (with-buffer-request (display +x-changeactivepointergrab+) ((or null cursor) cursor) ((or null card32) time) @@ -561,29 +561,29 @@ (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type timestamp time)) + (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) + (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) - (((data boolean) owner-p) - (window window) - ((or null card32) time) - (boolean (not sync-pointer-p) (not sync-keyboard-p))) + (((data boolean) owner-p) + (window window) + ((or null card32) time) + (boolean (not sync-pointer-p) (not sync-keyboard-p))) (values - (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) + (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-keyboard (display &key time) (declare (type display display) - (type timestamp time)) + (type timestamp time)) (with-buffer-request (display +x-ungrabkeyboard+) ((or null card32) time))) (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) (declare (type window window) - (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) + (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) + (type (or (member :any) card8) key) + (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-grabkey+) ((data boolean) owner-p) (window window) @@ -593,8 +593,8 @@ (defun ungrab-key (window key &key (modifiers 0)) (declare (type window window) - (type (or (member :any) card8) key) - (type modifier-mask modifiers)) + (type (or (member :any) card8) key) + (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabkey+) (data (if (eq key :any) 0 key)) (window window) @@ -602,15 +602,15 @@ (defun allow-events (display mode &optional time) (declare (type display display) - (type (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both) - mode) - (type timestamp time)) + (type (member :async-pointer :sync-pointer :replay-pointer + :async-keyboard :sync-keyboard :replay-keyboard + :async-both :sync-both) + mode) + (type timestamp time)) (with-buffer-request (display +x-allowevents+) ((data (member :async-pointer :sync-pointer :replay-pointer - :async-keyboard :sync-keyboard :replay-keyboard - :async-both :sync-both)) + :async-keyboard :sync-keyboard :replay-keyboard + :async-both :sync-both)) mode) ((or null card32) time))) @@ -627,37 +627,37 @@ `(let ((,disp ,display)) (declare (type display ,disp)) (unwind-protect - (progn - (grab-server ,disp) - ,@body) - (ungrab-server ,disp))))) + (progn + (grab-server ,disp) + ,@body) + (ungrab-server ,disp))))) (defun query-pointer (window) (declare (type window window)) (declare (clx-values x y same-screen-p child mask root-x root-y root)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) - ((window window)) + ((window window)) (values - (int16-get 20) - (int16-get 22) - (boolean-get 1) - (or-get 12 null window) - (card16-get 24) - (int16-get 16) - (int16-get 18) - (window-get 8))))) + (int16-get 20) + (int16-get 22) + (boolean-get 1) + (or-get 12 null window) + (card16-get 24) + (int16-get 16) + (int16-get 18) + (window-get 8))))) (defun pointer-position (window) (declare (type window window)) (declare (clx-values x y same-screen-p)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) - ((window window)) + ((window window)) (values - (int16-get 20) - (int16-get 22) - (boolean-get 1))))) + (int16-get 20) + (int16-get 22) + (boolean-get 1))))) (defun global-pointer-position (display) (declare (type display display)) @@ -671,36 +671,36 @@ (defun motion-events (window &key start stop (result-type 'list)) (declare (type window window) - (type timestamp start stop) - (type t result-type)) ;; a type specifier + (type timestamp start stop) + (type t result-type)) ;; a type specifier (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) - ((window window) - ((or null card32) start stop)) + ((window window) + ((or null card32) start stop)) (values - (sequence-get :result-type result-type :length (index* (card32-get 8) 3) - :index +replysize+))))) + (sequence-get :result-type result-type :length (index* (card32-get 8) 3) + :index +replysize+))))) (defun translate-coordinates (src src-x src-y dst) ;; Returns NIL when not on the same screen (declare (type window src) - (type int16 src-x src-y) - (type window dst)) + (type int16 src-x src-y) + (type window dst)) (declare (clx-values dst-x dst-y child)) (let ((display (window-display src))) (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) - ((window src dst) - (int16 src-x src-y)) + ((window src dst) + (int16 src-x src-y)) (and (boolean-get 1) - (values - (int16-get 12) - (int16-get 14) - (or-get 8 null window)))))) + (values + (int16-get 12) + (int16-get 14) + (or-get 8 null window)))))) (defun warp-pointer (dst dst-x dst-y) (declare (type window dst) - (type int16 dst-x dst-y)) + (type int16 dst-x dst-y)) (with-buffer-request ((window-display dst) +x-warppointer+) (resource-id 0) ;; None (window dst) @@ -710,7 +710,7 @@ (defun warp-pointer-relative (display x-off y-off) (declare (type display display) - (type int16 x-off y-off)) + (type int16 x-off y-off)) (with-buffer-request (display +x-warppointer+) (resource-id 0) ;; None (resource-id 0) ;; None @@ -719,12 +719,12 @@ (int16 x-off y-off))) (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y - &optional src-width src-height) + &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window dst src) - (type int16 dst-x dst-y src-x src-y) - (type (or null card16) src-width src-height)) + (type int16 dst-x dst-y src-x src-y) + (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display dst) +x-warppointer+) (window src dst) @@ -733,12 +733,12 @@ (int16 dst-x dst-y)))) (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y - &optional src-width src-height) + &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window src) - (type int16 x-off y-off src-x src-y) - (type (or null card16) src-width src-height)) + (type int16 x-off y-off src-x src-y) + (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display src) +x-warppointer+) (window src) @@ -749,9 +749,9 @@ (defun set-input-focus (display focus revert-to &optional time) (declare (type display display) - (type (or (member :none :pointer-root) window) focus) - (type (member :none :pointer-root :parent) revert-to) - (type timestamp time)) + (type (or (member :none :pointer-root) window) focus) + (type (member :none :pointer-root :parent) revert-to) + (type timestamp time)) (with-buffer-request (display +x-setinputfocus+) ((data (member :none :pointer-root :parent)) revert-to) ((or window (member :none :pointer-root)) focus) @@ -768,7 +768,7 @@ (defun query-keymap (display &optional bit-vector) (declare (type display display) - (type (or null (bit-vector 256)) bit-vector)) + (type (or null (bit-vector 256)) bit-vector)) (declare (clx-values (bit-vector 256))) (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) () @@ -776,19 +776,19 @@ (bit-vector256-get 8 8 bit-vector)))) (defun create-pixmap (&key - pixmap - (width (required-arg width)) - (height (required-arg height)) - (depth (required-arg depth)) - (drawable (required-arg drawable))) + pixmap + (width (required-arg width)) + (height (required-arg height)) + (depth (required-arg depth)) + (drawable (required-arg drawable))) (declare (type (or null pixmap) pixmap) - (type card8 depth) ;; required - (type card16 width height) ;; required - (type drawable drawable)) ;; required + (type card8 depth) ;; required + (type card16 width height) ;; required + (type drawable drawable)) ;; required (declare (clx-values pixmap)) (let* ((display (drawable-display drawable)) - (pixmap (or pixmap (make-pixmap :display display))) - (pid (allocate-resource-id display pixmap 'pixmap))) + (pixmap (or pixmap (make-pixmap :display display))) + (pid (allocate-resource-id display pixmap 'pixmap))) (setf (pixmap-id pixmap) pid) (with-buffer-request (display +x-createpixmap+) (data depth) @@ -808,9 +808,9 @@ ;; Passing in a zero width or height is a no-op. ;; A null width or height translates into a zero value in the protocol request. (declare (type window window) - (type int16 x y) - (type (or null card16) width height) - (type generalized-boolean exposures-p)) + (type int16 x y) + (type (or null card16) width height) + (type generalized-boolean exposures-p)) (unless (or (eql width 0) (eql height 0)) (with-buffer-request ((window-display window) +x-cleartobackground+) ((data boolean) exposures-p) @@ -820,9 +820,9 @@ (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) - (type gcontext gcontext) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) + (type gcontext gcontext) + (type int16 src-x src-y dst-x dst-y) + (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) @@ -831,10 +831,10 @@ (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) - (type gcontext gcontext) - (type pixel plane) - (type int16 src-x src-y dst-x dst-y) - (type card16 width height)) + (type gcontext gcontext) + (type pixel plane) + (type int16 src-x src-y dst-x dst-y) + (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) @@ -844,20 +844,20 @@ (defun create-colormap (visual-info window &optional alloc-p) (declare (type (or visual-info resource-id) visual-info) - (type window window) - (type generalized-boolean alloc-p)) + (type window window) + (type generalized-boolean alloc-p)) (declare (clx-values colormap)) (let ((display (window-display window))) (when (typep visual-info 'resource-id) (setf visual-info (visual-info display visual-info))) (let* ((colormap (make-colormap :display display :visual-info visual-info)) - (id (allocate-resource-id display colormap 'colormap))) + (id (allocate-resource-id display colormap 'colormap))) (setf (colormap-id colormap) id) (with-buffer-request (display +x-createcolormap+) - ((data boolean) alloc-p) - (card29 id) - (window window) - (card29 (visual-info-id visual-info))) + ((data boolean) alloc-p) + (card29 id) + (window window) + (card29 (visual-info-id visual-info))) colormap))) (defun free-colormap (colormap) @@ -871,9 +871,9 @@ (declare (type colormap colormap)) (declare (clx-values colormap)) (let* ((display (colormap-display colormap)) - (new-colormap (make-colormap :display display - :visual-info (colormap-visual-info colormap))) - (id (allocate-resource-id display new-colormap 'colormap))) + (new-colormap (make-colormap :display display + :visual-info (colormap-visual-info colormap))) + (id (allocate-resource-id display new-colormap 'colormap))) (setf (colormap-id new-colormap) id) (with-buffer-request (display +x-copycolormapandfree+) (resource-id id) @@ -892,95 +892,95 @@ (defun installed-colormaps (window &key (result-type 'list)) (declare (type window window) - (type t result-type)) ;; CL type + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence colormap))) (let ((display (window-display window))) (flet ((get-colormap (id) - (lookup-colormap display id))) + (lookup-colormap display id))) (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) - ((window window)) - (values - (sequence-get :result-type result-type :length (card16-get 8) - :transform #'get-colormap :index +replysize+)))))) + ((window window)) + (values + (sequence-get :result-type result-type :length (card16-get 8) + :transform #'get-colormap :index +replysize+)))))) (defun alloc-color (colormap color) (declare (type colormap colormap) - (type (or stringable color) color)) + (type (or stringable color) color)) (declare (clx-values pixel screen-color exact-color)) (let ((display (colormap-display colormap))) (etypecase color (color - (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) - ((colormap colormap) - (rgb-val (color-red color) - (color-green color) - (color-blue color)) - (pad16 nil)) - (values - (card32-get 16) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)) - color))) + (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) + ((colormap colormap) + (rgb-val (color-red color) + (color-green color) + (color-blue color)) + (pad16 nil)) + (values + (card32-get 16) + (make-color :red (rgb-val-get 8) + :green (rgb-val-get 10) + :blue (rgb-val-get 12)) + color))) (stringable - (let* ((string (string color)) - (length (length string))) - (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) - (values - (card32-get 8) - (make-color :red (rgb-val-get 18) - :green (rgb-val-get 20) - :blue (rgb-val-get 22)) - (make-color :red (rgb-val-get 12) - :green (rgb-val-get 14) - :blue (rgb-val-get 16))))))))) + (let* ((string (string color)) + (length (length string))) + (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) + ((colormap colormap) + (card16 length) + (pad16 nil) + (string string)) + (values + (card32-get 8) + (make-color :red (rgb-val-get 18) + :green (rgb-val-get 20) + :blue (rgb-val-get 22)) + (make-color :red (rgb-val-get 12) + :green (rgb-val-get 14) + :blue (rgb-val-get 16))))))))) (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) - (type card16 colors planes) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type + (type card16 colors planes) + (type generalized-boolean contiguous-p) + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors planes)) + (((data boolean) contiguous-p) + (colormap colormap) + (card16 colors planes)) (let ((pixel-length (card16-get 8)) - (mask-length (card16-get 10))) - (values - (sequence-get :result-type result-type :length pixel-length :index +replysize+) - (sequence-get :result-type result-type :length mask-length - :index (index+ +replysize+ (index* pixel-length 4)))))))) + (mask-length (card16-get 10))) + (values + (sequence-get :result-type result-type :length pixel-length :index +replysize+) + (sequence-get :result-type result-type :length mask-length + :index (index+ +replysize+ (index* pixel-length 4)))))))) (defun alloc-color-planes (colormap colors - &key (reds 0) (greens 0) (blues 0) - contiguous-p (result-type 'list)) + &key (reds 0) (greens 0) (blues 0) + contiguous-p (result-type 'list)) (declare (type colormap colormap) - (type card16 colors reds greens blues) - (type generalized-boolean contiguous-p) - (type t result-type)) ;; CL type + (type card16 colors reds greens blues) + (type generalized-boolean contiguous-p) + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) - (((data boolean) contiguous-p) - (colormap colormap) - (card16 colors reds greens blues)) + (((data boolean) contiguous-p) + (colormap colormap) + (card16 colors reds greens blues)) (let ((red-mask (card32-get 12)) - (green-mask (card32-get 16)) - (blue-mask (card32-get 20))) - (values - (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) - red-mask green-mask blue-mask))))) + (green-mask (card32-get 16)) + (blue-mask (card32-get 20))) + (values + (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) + red-mask green-mask blue-mask))))) (defun free-colors (colormap pixels &optional (plane-mask 0)) (declare (type colormap colormap) - (type sequence pixels) ;; Sequence of integers - (type pixel plane-mask)) + (type sequence pixels) ;; Sequence of integers + (type pixel plane-mask)) (with-buffer-request ((colormap-display colormap) +x-freecolors+) (colormap colormap) (card32 plane-mask) @@ -988,140 +988,140 @@ (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) (declare (type colormap colormap) - (type pixel pixel) - (type (or stringable color) spec) - (type generalized-boolean red-p green-p blue-p)) + (type pixel pixel) + (type (or stringable color) spec) + (type generalized-boolean red-p green-p blue-p)) (let ((display (colormap-display colormap)) - (flags 0)) + (flags 0)) (declare (type display display) - (type card8 flags)) + (type card8 flags)) (when red-p (setq flags 1)) (when green-p (incf flags 2)) (when blue-p (incf flags 4)) (etypecase spec (color - (with-buffer-request (display +x-storecolors+) - (colormap colormap) - (card32 pixel) - (rgb-val (color-red spec) - (color-green spec) - (color-blue spec)) - (card8 flags) - (pad8 nil))) + (with-buffer-request (display +x-storecolors+) + (colormap colormap) + (card32 pixel) + (rgb-val (color-red spec) + (color-green spec) + (color-blue spec)) + (card8 flags) + (pad8 nil))) (stringable - (let* ((string (string spec)) - (length (length string))) - (with-buffer-request (display +x-storenamedcolor+) - ((data card8) flags) - (colormap colormap) - (card32 pixel) - (card16 length) - (pad16 nil) - (string string))))))) + (let* ((string (string spec)) + (length (length string))) + (with-buffer-request (display +x-storenamedcolor+) + ((data card8) flags) + (colormap colormap) + (card32 pixel) + (card16 length) + (pad16 nil) + (string string))))))) (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) ;; If stringables are specified for colors, it is unspecified whether all ;; stringables are first resolved and then a single StoreColors protocol request is ;; issued, or whether multiple StoreColors protocol requests are issued. (declare (type colormap colormap) - (type sequence specs) - (type generalized-boolean red-p green-p blue-p)) + (type sequence specs) + (type generalized-boolean red-p green-p blue-p)) (etypecase specs (list (do ((spec specs (cddr spec))) - ((endp spec)) - (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) + ((endp spec)) + (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) (vector (do ((i 0 (+ i 2)) - (len (length specs))) - ((>= i len)) - (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) + (len (length specs))) + ((>= i len)) + (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) (defun query-colors (colormap pixels &key (result-type 'list)) (declare (type colormap colormap) - (type sequence pixels) ;; sequence of integer - (type t result-type)) ;; a type specifier + (type sequence pixels) ;; sequence of integer + (type t result-type)) ;; a type specifier (declare (clx-values (clx-sequence color))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) - ((colormap colormap) - (sequence pixels)) + ((colormap colormap) + (sequence pixels)) (let ((sequence (make-sequence result-type (card16-get 8)))) - (advance-buffer-offset +replysize+) - (dotimes (i (length sequence) sequence) - (setf (elt sequence i) - (make-color :red (rgb-val-get 0) - :green (rgb-val-get 2) - :blue (rgb-val-get 4))) - (advance-buffer-offset 8)))))) + (advance-buffer-offset +replysize+) + (dotimes (i (length sequence) sequence) + (setf (elt sequence i) + (make-color :red (rgb-val-get 0) + :green (rgb-val-get 2) + :blue (rgb-val-get 4))) + (advance-buffer-offset 8)))))) (defun lookup-color (colormap name) (declare (type colormap colormap) - (type stringable name)) + (type stringable name)) (declare (clx-values screen-color true-color)) (let* ((display (colormap-display colormap)) - (string (string name)) - (length (length string))) + (string (string name)) + (length (length string))) (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) - ((colormap colormap) - (card16 length) - (pad16 nil) - (string string)) + ((colormap colormap) + (card16 length) + (pad16 nil) + (string string)) (values - (make-color :red (rgb-val-get 14) - :green (rgb-val-get 16) - :blue (rgb-val-get 18)) - (make-color :red (rgb-val-get 8) - :green (rgb-val-get 10) - :blue (rgb-val-get 12)))))) + (make-color :red (rgb-val-get 14) + :green (rgb-val-get 16) + :blue (rgb-val-get 18)) + (make-color :red (rgb-val-get 8) + :green (rgb-val-get 10) + :blue (rgb-val-get 12)))))) (defun create-cursor (&key - (source (required-arg source)) - mask - (x (required-arg x)) - (y (required-arg y)) - (foreground (required-arg foreground)) - (background (required-arg background))) + (source (required-arg source)) + mask + (x (required-arg x)) + (y (required-arg y)) + (foreground (required-arg foreground)) + (background (required-arg background))) (declare (type pixmap source) ;; required - (type (or null pixmap) mask) - (type card16 x y) ;; required - (type (or null color) foreground background)) ;; required + (type (or null pixmap) mask) + (type card16 x y) ;; required + (type (or null color) foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (pixmap-display source)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor))) + (cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display +x-createcursor+) (resource-id cid) (pixmap source) ((or null pixmap) mask) (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) + (color-green foreground) + (color-blue foreground)) (rgb-val (color-red background) - (color-green background) - (color-blue background)) + (color-green background) + (color-blue background)) (card16 x y)) cursor)) (defun create-glyph-cursor (&key - (source-font (required-arg source-font)) - (source-char (required-arg source-char)) - mask-font - mask-char - (foreground (required-arg foreground)) - (background (required-arg background))) + (source-font (required-arg source-font)) + (source-char (required-arg source-char)) + mask-font + mask-char + (foreground (required-arg foreground)) + (background (required-arg background))) (declare (type font source-font) ;; Required - (type card16 source-char) ;; Required - (type (or null font) mask-font) - (type (or null card16) mask-char) - (type color foreground background)) ;; required + (type card16 source-char) ;; Required + (type (or null font) mask-font) + (type (or null card16) mask-char) + (type color foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (font-display source-font)) - (cursor (make-cursor :display display)) - (cid (allocate-resource-id display cursor 'cursor)) - (source-font-id (font-id source-font)) - (mask-font-id (if mask-font (font-id mask-font) 0))) + (cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor)) + (source-font-id (font-id source-font)) + (mask-font-id (if mask-font (font-id mask-font) 0))) (setf (cursor-id cursor) cid) (unless mask-char (setq mask-char 0)) (with-buffer-request (display +x-createglyphcursor+) @@ -1129,11 +1129,11 @@ (card16 source-char) (card16 mask-char) (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) + (color-green foreground) + (color-blue foreground)) (rgb-val (color-red background) - (color-green background) - (color-blue background))) + (color-green background) + (color-blue background))) cursor)) (defun free-cursor (cursor) @@ -1145,94 +1145,94 @@ (defun recolor-cursor (cursor foreground background) (declare (type cursor cursor) - (type color foreground background)) + (type color foreground background)) (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) (cursor cursor) (rgb-val (color-red foreground) - (color-green foreground) - (color-blue foreground)) + (color-green foreground) + (color-blue foreground)) (rgb-val (color-red background) - (color-green background) - (color-blue background)) + (color-green background) + (color-blue background)) )) (defun query-best-cursor (width height drawable) (declare (type card16 width height) - (type (or drawable display) drawable)) + (type (or drawable display) drawable)) (declare (clx-values width height)) ;; Drawable can be a display for compatibility. (multiple-value-bind (display drawable) (if (type? drawable 'drawable) - (values (drawable-display drawable) drawable) - (values drawable (screen-root (display-default-screen drawable)))) + (values (drawable-display drawable) drawable) + (values drawable (screen-root (display-default-screen drawable)))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 0) - (window drawable) - (card16 width height)) + ((data 0) + (window drawable) + (card16 width height)) (values - (card16-get 8) - (card16-get 10))))) + (card16-get 8) + (card16-get 10))))) (defun query-best-tile (width height drawable) (declare (type card16 width height) - (type drawable drawable)) + (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 1) - (drawable drawable) - (card16 width height)) + ((data 1) + (drawable drawable) + (card16 width height)) (values - (card16-get 8) - (card16-get 10))))) + (card16-get 8) + (card16-get 10))))) (defun query-best-stipple (width height drawable) (declare (type card16 width height) - (type drawable drawable)) + (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) - ((data 2) - (drawable drawable) - (card16 width height)) + ((data 2) + (drawable drawable) + (card16 width height)) (values - (card16-get 8) - (card16-get 10))))) + (card16-get 8) + (card16-get 10))))) (defun query-extension (display name) (declare (type display display) - (type stringable name)) + (type stringable name)) (declare (clx-values major-opcode first-event first-error)) (let ((string (string name))) (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) - ((card16 (length string)) - (pad16 nil) - (string string)) + ((card16 (length string)) + (pad16 nil) + (string string)) (and (boolean-get 8) ;; If present - (values - (card8-get 9) - (card8-get 10) - (card8-get 11)))))) + (values + (card8-get 9) + (card8-get 10) + (card8-get 11)))))) (defun list-extensions (display &key (result-type 'list)) (declare (type display display) - (type t result-type)) ;; CL type + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) () (values (read-sequence-string - buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) + buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) (defun change-keyboard-control (display &key key-click-percent - bell-percent bell-pitch bell-duration - led led-mode key auto-repeat-mode) + bell-percent bell-pitch bell-duration + led led-mode key auto-repeat-mode) (declare (type display display) - (type (or null (member :default) int16) key-click-percent - bell-percent bell-pitch bell-duration) - (type (or null card8) led key) - (type (or null (member :on :off)) led-mode) - (type (or null (member :on :off :default)) auto-repeat-mode)) + (type (or null (member :default) int16) key-click-percent + bell-percent bell-pitch bell-duration) + (type (or null card8) led key) + (type (or null (member :on :off)) led-mode) + (type (or null (member :on :off :default)) auto-repeat-mode)) (when (eq key-click-percent :default) (setq key-click-percent -1)) (when (eq bell-percent :default) (setq bell-percent -1)) (when (eq bell-pitch :default) (setq bell-pitch -1)) @@ -1248,7 +1248,7 @@ (defun keyboard-control (display) (declare (type display display)) (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration - led-mask global-auto-repeat auto-repeats)) + led-mask global-auto-repeat auto-repeats)) (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) () (values @@ -1266,35 +1266,35 @@ ;; than using a simple sum, the percent argument is instead used as the ;; percentage of the remaining range to alter the base volume by. That is, ;; the actual volume is: -;; if percent>=0: base - [(base * percent) / 100] + percent -;; if percent<0: base + [(base * percent) / 100] +;; if percent>=0: base - [(base * percent) / 100] + percent +;; if percent<0: base + [(base * percent) / 100] (defun bell (display &optional (percent-from-normal 0)) ;; It is assumed that an eventual audio extension to X will provide more complete control. (declare (type display display) - (type int8 percent-from-normal)) + (type int8 percent-from-normal)) (with-buffer-request (display +x-bell+) (data (int8->card8 percent-from-normal)))) (defun pointer-mapping (display &key (result-type 'list)) (declare (type display display) - (type t result-type)) ;; CL type + (type t result-type)) ;; CL type (declare (clx-values sequence)) ;; Sequence of card (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) () (values (sequence-get :length (card8-get 1) :result-type result-type :format card8 - :index +replysize+)))) + :index +replysize+)))) (defun set-pointer-mapping (display map) ;; Can signal device-busy. (declare (type display display) - (type sequence map)) ;; Sequence of card8 + (type sequence map)) ;; Sequence of card8 (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) - ((data (length map)) - ((sequence :format card8) map)) - (values - (boolean-get 1))) + ((data (length map)) + ((sequence :format card8) map)) + (values + (boolean-get 1))) (x-error 'device-busy :display display)) map) @@ -1303,37 +1303,37 @@ (defun change-pointer-control (display &key acceleration threshold) ;; Acceleration is rationalized if necessary. (declare (type display display) - (type (or null (member :default) number) acceleration) - (type (or null (member :default) integer) threshold)) + (type (or null (member :default) number) acceleration) + (type (or null (member :default) integer) threshold)) (flet ((rationalize16 (number) - ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers - (declare (type number number)) - (declare (clx-values numerator denominator)) - (do* ((rational (rationalize number)) - (numerator (numerator rational) (ash numerator -1)) - (denominator (denominator rational) (ash denominator -1))) - ((or (= numerator 1) - (and (< (abs numerator) #x8000) - (< denominator #x8000))) - (values - numerator (min denominator #x7fff)))))) + ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers + (declare (type number number)) + (declare (clx-values numerator denominator)) + (do* ((rational (rationalize number)) + (numerator (numerator rational) (ash numerator -1)) + (denominator (denominator rational) (ash denominator -1))) + ((or (= numerator 1) + (and (< (abs numerator) #x8000) + (< denominator #x8000))) + (values + numerator (min denominator #x7fff)))))) (declare (inline rationalize16)) (let ((acceleration-p 1) - (threshold-p 1) - (numerator 0) - (denominator 1)) + (threshold-p 1) + (numerator 0) + (denominator 1)) (declare (type card8 acceleration-p threshold-p) - (type int16 numerator denominator)) + (type int16 numerator denominator)) (cond ((eq acceleration :default) (setq numerator -1)) - (acceleration (multiple-value-setq (numerator denominator) - (rationalize16 acceleration))) - (t (setq acceleration-p 0))) + (acceleration (multiple-value-setq (numerator denominator) + (rationalize16 acceleration))) + (t (setq acceleration-p 0))) (cond ((eq threshold :default) (setq threshold -1)) - ((null threshold) (setq threshold -1 - threshold-p 0))) + ((null threshold) (setq threshold -1 + threshold-p 0))) (with-buffer-request (display +x-changepointercontrol+) - (int16 numerator denominator threshold) - (card8 acceleration-p threshold-p))))) + (int16 numerator denominator threshold) + (card8 acceleration-p threshold-p))))) (defun pointer-control (display) (declare (type display display)) @@ -1341,14 +1341,14 @@ (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) () (values - (/ (card16-get 8) (card16-get 10)) ; Should we float this? + (/ (card16-get 8) (card16-get 10)) ; Should we float this? (card16-get 12)))) (defun set-screen-saver (display timeout interval blanking exposures) ;; Timeout and interval are in seconds, will be rounded to minutes. (declare (type display display) - (type (or (member :default) int16) timeout interval) - (type (member :on :off :default :yes :no) blanking exposures)) + (type (or (member :default) int16) timeout interval) + (type (member :on :off :default :yes :no) blanking exposures)) (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) (when (eq timeout :default) (setq timeout -1)) @@ -1385,8 +1385,8 @@ ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family nil)) (defun remove-access-host (display host &optional (family :internet)) @@ -1395,18 +1395,18 @@ ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family t)) (defun change-access-host (display host family remove-p) (declare (type display display) - (type (or stringable list) host) - (type (or null (member :internet :decnet :chaos) card8) family)) + (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) (unless (consp host) (setq host (host-address host family))) (let ((family (car host)) - (address (cdr host))) + (address (cdr host))) (with-buffer-request (display +x-changehosts+) ((data boolean) remove-p) (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) @@ -1419,27 +1419,27 @@ ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) - (type t result-type)) ;; CL type + (type t result-type)) ;; CL type (declare (clx-values (clx-sequence host) enabled-p)) (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) () (let* ((enabled-p (boolean-get 1)) - (nhosts (card16-get 8)) - (sequence (make-sequence result-type nhosts))) + (nhosts (card16-get 8)) + (sequence (make-sequence result-type nhosts))) (advance-buffer-offset +replysize+) (dotimes (i nhosts) - (let ((family (card8-get 0)) - (len (card16-get 2))) - (setf (elt sequence i) - (cons (if (< family 3) - (svref '#(:internet :decnet :chaos) family) - family) - (sequence-get :length len :format card8 :result-type 'list - :index (+ buffer-boffset 4)))) - (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) + (let ((family (card8-get 0)) + (len (card16-get 2))) + (setf (elt sequence i) + (cons (if (< family 3) + (svref '#(:internet :decnet :chaos) family) + family) + (sequence-get :length len :format card8 :result-type 'list + :index (+ buffer-boffset 4)))) + (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) (values - sequence - enabled-p)))) + sequence + enabled-p)))) (defun access-control (display) (declare (type display display)) @@ -1450,7 +1450,7 @@ (defun set-access-control (display enabled-p) (declare (type display display) - (type generalized-boolean enabled-p)) + (type generalized-boolean enabled-p)) (with-buffer-request (display +x-changeaccesscontrol+) ((data boolean) enabled-p)) enabled-p) @@ -1467,7 +1467,7 @@ (defun set-close-down-mode (display mode) ;; Cached locally in display object. (declare (type display display) - (type (member :destroy :retain-permanent :retain-temporary) mode)) + (type (member :destroy :retain-permanent :retain-temporary) mode)) (setf (display-close-down-mode display) mode) (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) ((data (member :destroy :retain-permanent :retain-temporary)) mode)) @@ -1477,7 +1477,7 @@ (defun kill-client (display resource-id) (declare (type display display) - (type resource-id resource-id)) + (type resource-id resource-id)) (with-buffer-request (display +x-killclient+) (resource-id resource-id))) diff --git a/src/clx/resource.lisp b/src/clx/resource.lisp index 7526868e2..50feec547 100644 --- a/src/clx/resource.lisp +++ b/src/clx/resource.lisp @@ -3,9 +3,9 @@ ;; RESOURCE - Lisp version of XLIB's Xrm resource manager ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -24,10 +24,10 @@ ;; Small hash tables lose in Lisp, so we do linear searches on lists. (defstruct (resource-database (:copier nil) (:predicate nil) - (:print-function print-resource-database) - (:constructor make-resource-database-internal) - #+explorer (:callable-constructors nil) - ) + (:print-function print-resource-database) + (:constructor make-resource-database-internal) + #+explorer (:callable-constructors nil) + ) (name nil :type stringable :read-only t) (value nil) (tight nil :type list) ;; List of resource-database @@ -36,7 +36,7 @@ (defun print-resource-database (database stream depth) (declare (type resource-database database) - (ignore depth)) + (ignore depth)) (print-unreadable-object (database stream :type t) (write-string (string (resource-database-name database)) stream) (when (resource-database-value database) @@ -59,18 +59,18 @@ (declare (type resource-database database)) (let ((timestamp (resource-database-value database))) (setf (resource-database-value database) - (if (= timestamp most-positive-fixnum) - most-negative-fixnum - (1+ timestamp))))) + (if (= timestamp most-positive-fixnum) + most-negative-fixnum + (1+ timestamp))))) ;; DEBUG FUNCTION (not exported) (defun print-db (entry &optional (level 0) type) ;; Debug function to print a resource database (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" - level - (resource-database-name entry) - (eq type 'loose) - (resource-database-value entry)) + level + (resource-database-name entry) + (eq type 'loose) + (resource-database-value entry)) (when (resource-database-tight entry) (dolist (tight (resource-database-tight entry)) (print-db tight (+ 2 level) 'tight))) @@ -87,9 +87,9 @@ (dolist (db dbase-list) (print-db db) (dolist (dblist table) - (unless (eq dblist dbase-list) - (when (member db dblist) - (format t " duplicate at ~s" db)))) + (unless (eq dblist dbase-list) + (when (member db dblist) + (format t " duplicate at ~s" db)))) ))) ;; @@ -104,12 +104,12 @@ (etypecase stringable (symbol (if (keywordp (the symbol stringable)) - stringable - (kintern (symbol-name (the symbol stringable))))) + stringable + (kintern (symbol-name (the symbol stringable))))) (string (if *uppercase-resource-symbols* - (setq stringable (#-allegro string-upcase #+allegro correct-case - (the string stringable)))) + (setq stringable (#-allegro string-upcase #+allegro correct-case + (the string stringable)))) (kintern (the string stringable))))) (defun stringable-equal (a b) @@ -120,25 +120,25 @@ (etypecase a (string (etypecase b - (string - (string= (the string a) (the string b))) - (symbol - (if *uppercase-resource-symbols* - (string-equal (the string a) - (the string (symbol-name (the symbol b)))) - (string= (the string a) - (the string (symbol-name (the symbol b)))))))) + (string + (string= (the string a) (the string b))) + (symbol + (if *uppercase-resource-symbols* + (string-equal (the string a) + (the string (symbol-name (the symbol b)))) + (string= (the string a) + (the string (symbol-name (the symbol b)))))))) (symbol (etypecase b - (string - (if *uppercase-resource-symbols* - (string-equal (the string (symbol-name (the symbol a))) - (the string b)) - (string= (the string (symbol-name (the symbol a))) - (the string b)))) - (symbol - (string= (the string (symbol-name (the symbol a))) - (the string (symbol-name (the symbol b))))))))) + (string + (if *uppercase-resource-symbols* + (string-equal (the string (symbol-name (the symbol a))) + (the string b)) + (string= (the string (symbol-name (the symbol a))) + (the string b)))) + (symbol + (string= (the string (symbol-name (the symbol a))) + (the string (symbol-name (the symbol b))))))))) ;;;----------------------------------------------------------------------------- @@ -150,78 +150,78 @@ ;; case-sensitive comparisons will be used. The symbol '* or ;; string "*" are used as wildcards, matching anything or nothing. (declare (type resource-database database) - (type (clx-list stringable) name-list) - (type t value)) + (type (clx-list stringable) name-list) + (type t value)) (unless value (error "Null resource values are ignored")) (incf-resource-database-timestamp database) (do* ((list name-list (cdr list)) - (name (car list) (car list)) - (node database) - (loose-p nil)) + (name (car list) (car list)) + (node database) + (loose-p nil)) ((endp list) - (setf (resource-database-value node) value)) + (setf (resource-database-value node) value)) ;; Key is the first name that isn't * (if (stringable-equal name "*") - (setq loose-p t) + (setq loose-p t) ;; find the entry associated with name (progn - (do ((entry (if loose-p - (resource-database-loose node) - (resource-database-tight node)) - (cdr entry))) - ((endp entry) - ;; Entry not found - create a new one - (setq entry (make-resource-database-internal :name name)) - (if loose-p - (push entry (resource-database-loose node)) - (push entry (resource-database-tight node))) - (setq node entry)) - (when (stringable-equal name (resource-database-name (car entry))) - ;; Found entry - use it - (return (setq node (car entry))))) - (setq loose-p nil))))) + (do ((entry (if loose-p + (resource-database-loose node) + (resource-database-tight node)) + (cdr entry))) + ((endp entry) + ;; Entry not found - create a new one + (setq entry (make-resource-database-internal :name name)) + (if loose-p + (push entry (resource-database-loose node)) + (push entry (resource-database-tight node))) + (setq node entry)) + (when (stringable-equal name (resource-database-name (car entry))) + ;; Found entry - use it + (return (setq node (car entry))))) + (setq loose-p nil))))) (defun delete-resource (database name-list) (declare (type resource-database database) - (type list name-list)) + (type list name-list)) (incf-resource-database-timestamp database) (delete-resource-internal database name-list)) (defun delete-resource-internal (database name-list) (declare (type resource-database database) - (type (clx-list stringable) name-list)) + (type (clx-list stringable) name-list)) (do* ((list name-list (cdr list)) - (string (car list) (car list)) - (node database) - (loose-p nil)) + (string (car list) (car list)) + (node database) + (loose-p nil)) ((endp list) nil) ;; Key is the first name that isn't * (if (stringable-equal string "*") - (setq loose-p t) + (setq loose-p t) ;; find the entry associated with name (progn - (do* ((first-entry (if loose-p - (resource-database-loose node) - (resource-database-tight node))) - (entry-list first-entry (cdr entry-list)) - (entry (car entry-list) (car entry-list))) - ((endp entry-list) - ;; Entry not found - exit - (return-from delete-resource-internal nil)) - (when (stringable-equal string (resource-database-name entry)) - (when (cdr list) (delete-resource-internal entry (cdr list))) - (when (and (null (resource-database-loose entry)) - (null (resource-database-tight entry))) - (if loose-p - (setf (resource-database-loose node) - (delete entry (resource-database-loose node) - :test #'eq :count 1)) - (setf (resource-database-tight node) - (delete entry (resource-database-tight node) - :test #'eq :count 1)))) - (return-from delete-resource-internal t))) - (setq loose-p nil))))) + (do* ((first-entry (if loose-p + (resource-database-loose node) + (resource-database-tight node))) + (entry-list first-entry (cdr entry-list)) + (entry (car entry-list) (car entry-list))) + ((endp entry-list) + ;; Entry not found - exit + (return-from delete-resource-internal nil)) + (when (stringable-equal string (resource-database-name entry)) + (when (cdr list) (delete-resource-internal entry (cdr list))) + (when (and (null (resource-database-loose entry)) + (null (resource-database-tight entry))) + (if loose-p + (setf (resource-database-loose node) + (delete entry (resource-database-loose node) + :test #'eq :count 1)) + (setf (resource-database-tight node) + (delete entry (resource-database-tight node) + :test #'eq :count 1)))) + (return-from delete-resource-internal t))) + (setq loose-p nil))))) ;;;----------------------------------------------------------------------------- ;;; Get Resource @@ -231,61 +231,61 @@ ;; most closely matches (append full-name (list value-name)) and ;; (append full-class (list value-class)). (declare (type resource-database database) - (type stringable value-name value-class) - (type (clx-list stringable) full-name full-class)) + (type stringable value-name value-class) + (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let ((names (append full-name (list value-name))) - (classes (append full-class (list value-class)))) + (classes (append full-class (list value-class)))) (let* ((result (get-entry (resource-database-tight database) - (resource-database-loose database) - names classes))) + (resource-database-loose database) + names classes))) (when result - (resource-database-value result))))) + (resource-database-value result))))) (defun get-entry-lookup (table name names classes) (declare (type list table names classes) - (symbol name)) + (symbol name)) (dolist (entry table) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (if (null (cdr names)) - (return entry) - (let ((result (get-entry (resource-database-tight entry) - (resource-database-loose entry) - (cdr names) (cdr classes)))) - (declare (type (or null resource-database) result)) - (when result - (return result) - )))))) + (return entry) + (let ((result (get-entry (resource-database-tight entry) + (resource-database-loose entry) + (cdr names) (cdr classes)))) + (declare (type (or null resource-database) result)) + (when result + (return result) + )))))) (defun get-entry (tight loose names classes &aux result) (declare (type list tight loose names classes)) (let ((name (car names)) - (class (car classes))) + (class (car classes))) (declare (type symbol name class)) (cond ((and tight - (get-entry-lookup tight name names classes))) - ((and loose - (get-entry-lookup loose name names classes))) - ((and tight - (not (stringable-equal name class)) - (get-entry-lookup tight class names classes))) - ((and loose - (not (stringable-equal name class)) - (get-entry-lookup loose class names classes))) - (loose - (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (when (setq result (get-entry-lookup loose name names classes)) - (return result)) - (when (and (not (stringable-equal name class)) - (setq result - (get-entry-lookup loose class names classes))) - (return result)) - ))))) + (get-entry-lookup tight name names classes))) + ((and loose + (get-entry-lookup loose name names classes))) + ((and tight + (not (stringable-equal name class)) + (get-entry-lookup tight class names classes))) + ((and loose + (not (stringable-equal name class)) + (get-entry-lookup loose class names classes))) + (loose + (loop + (pop names) (pop classes) + (unless (and names classes) (return nil)) + (setq name (car names) + class (car classes)) + (when (setq result (get-entry-lookup loose name names classes)) + (return result)) + (when (and (not (stringable-equal name class)) + (setq result + (get-entry-lookup loose class names classes))) + (return result)) + ))))) ;;;----------------------------------------------------------------------------- @@ -300,38 +300,38 @@ ;; get-search-resource is MUCH faster when getting several resources with ;; the same full-name/full-class (declare (type list table) - (type stringable name class)) + (type stringable name class)) (let ((do-class (and class (not (stringable-equal name class))))) (dolist (dbase-list table) (declare (type list dbase-list)) (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal name (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))) + (declare (type resource-database dbase)) + (when (stringable-equal name (resource-database-name dbase)) + (return-from get-search-resource + (resource-database-value dbase)))) (when do-class - (dolist (dbase dbase-list) - (declare (type resource-database dbase)) - (when (stringable-equal class (resource-database-name dbase)) - (return-from get-search-resource - (resource-database-value dbase)))))))) + (dolist (dbase dbase-list) + (declare (type resource-database dbase)) + (when (stringable-equal class (resource-database-name dbase)) + (return-from get-search-resource + (resource-database-value dbase)))))))) (defvar *get-table-result*) (defun get-search-table (database full-name full-class) ;; Return a search table for use with get-search-resource. (declare (type resource-database database) - (type (clx-list stringable) full-name full-class)) + (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let* ((tight (resource-database-tight database)) - (loose (resource-database-loose database)) - (result (cons nil nil)) - (*get-table-result* result)) + (loose (resource-database-loose database)) + (result (cons nil nil)) + (*get-table-result* result)) (declare (type list tight loose) - (type cons result)) + (type cons result)) (when (or tight loose) (when full-name - (get-tables tight loose full-name full-class)) + (get-tables tight loose full-name full-class)) ;; Pick up bindings of the form (* name). These are the elements of ;; top-level loose without further tight/loose databases. @@ -341,42 +341,42 @@ ;; data-structure/algorithm.) ;; (let ((universal-bindings - (remove nil loose :test-not #'eq - :key #'(lambda (database) - (or (resource-database-tight database) - (resource-database-loose database)))))) - (when universal-bindings - (setf (cdr *get-table-result*) (list universal-bindings))))) + (remove nil loose :test-not #'eq + :key #'(lambda (database) + (or (resource-database-tight database) + (resource-database-loose database)))))) + (when universal-bindings + (setf (cdr *get-table-result*) (list universal-bindings))))) (cdr result))) (defun get-tables-lookup (dbase name names classes) (declare (type list dbase names classes) - (type symbol name)) + (type symbol name)) (declare (optimize speed)) (dolist (entry dbase) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (let ((tight (resource-database-tight entry)) - (loose (resource-database-loose entry))) - (declare (type list tight loose)) - (when (or tight loose) - (if (cdr names) - (get-tables tight loose (cdr names) (cdr classes)) - (when tight - (let ((result *get-table-result*)) - ;; Put tight at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons tight nil)))))) - (when loose - (let ((result *get-table-result*)) - ;; Put loose at end of *get-table-result* - (setf (cdr result) - (setq *get-table-result* (cons loose nil)))))))))) + (loose (resource-database-loose entry))) + (declare (type list tight loose)) + (when (or tight loose) + (if (cdr names) + (get-tables tight loose (cdr names) (cdr classes)) + (when tight + (let ((result *get-table-result*)) + ;; Put tight at end of *get-table-result* + (setf (cdr result) + (setq *get-table-result* (cons tight nil)))))) + (when loose + (let ((result *get-table-result*)) + ;; Put loose at end of *get-table-result* + (setf (cdr result) + (setq *get-table-result* (cons loose nil)))))))))) (defun get-tables (tight loose names classes) (declare (type list tight loose names classes)) (let ((name (car names)) - (class (car classes))) + (class (car classes))) (declare (type symbol name class)) (when tight (get-tables-lookup tight name names classes)) @@ -388,14 +388,14 @@ (get-tables-lookup loose class names classes)) (when loose (loop - (pop names) (pop classes) - (unless (and names classes) (return nil)) - (setq name (car names) - class (car classes)) - (get-tables-lookup loose name names classes) - (unless (stringable-equal name class) - (get-tables-lookup loose class names classes)) - )))) + (pop names) (pop classes) + (unless (and names classes) (return nil)) + (setq name (car names) + class (car classes)) + (get-tables-lookup loose name names classes) + (unless (stringable-equal name class) + (get-tables-lookup loose class names classes)) + )))) ;;;----------------------------------------------------------------------------- @@ -405,42 +405,42 @@ ;; Call FUNCTION on each resource in DATABASE. ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) - (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) - (dynamic-extent args)) + (type (function (list t &rest t) t) function) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg function) + (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) - (declare (type resource-database database) - (type (function (list t &rest t) t) function) - (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) - (let ((tight (resource-database-tight database)) - (loose (resource-database-loose database))) - (declare (type list tight loose)) - (dolist (resource tight) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name)))) - (dolist (resource loose) - (declare (type resource-database resource)) - (let ((value (resource-database-value resource)) - (name (append - name - (list "*" (resource-database-name resource))))) - (if value - (apply function name value args) - (map-resource-internal resource function args name))))))) + (declare (type resource-database database) + (type (function (list t &rest t) t) function) + (type list name) + #+clx-ansi-common-lisp + (dynamic-extent function) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg function)) + (let ((tight (resource-database-tight database)) + (loose (resource-database-loose database))) + (declare (type list tight loose)) + (dolist (resource tight) + (declare (type resource-database resource)) + (let ((value (resource-database-value resource)) + (name (append + name + (list (resource-database-name resource))))) + (if value + (apply function name value args) + (map-resource-internal resource function args name)))) + (dolist (resource loose) + (declare (type resource-database resource)) + (let ((value (resource-database-value resource)) + (name (append + name + (list "*" (resource-database-name resource))))) + (if value + (apply function name value args) + (map-resource-internal resource function args name))))))) (map-resource-internal database function args nil))) (defun merge-resources (database with-database) @@ -449,7 +449,7 @@ (map-resource database #'(lambda (name value database) - (add-resource database name value)) + (add-resource database name value)) with-database) with-database) @@ -462,16 +462,16 @@ ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the ;; stream (let ((abortp (gensym)) - (streamp (gensym))) + (streamp (gensym))) `(let* ((,abortp t) - (,streamp (streamp pathname)) - (,stream (if ,streamp pathname (open ,pathname ,@options)))) + (,streamp (streamp pathname)) + (,stream (if ,streamp pathname (open ,pathname ,@options)))) (unwind-protect - (multiple-value-prog1 - (progn ,@body) - (setq ,abortp nil)) - (unless ,streamp - (close stream :abort ,abortp)))))) + (multiple-value-prog1 + (progn ,@body) + (setq ,abortp nil)) + (unless ,streamp + (close stream :abort ,abortp)))))) (defun read-resources (database pathname &key key test test-not) ;; Merges resources from a file in standard X11 format with DATABASE. @@ -480,53 +480,53 @@ ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) + (type (or pathname string stream) pathname) + (type (or null (function (string) t)) key) + (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (resource-with-open-file (stream pathname) (loop (let ((string (read-line stream nil :eof))) - (declare (type (or string keyword) string)) - (when (eq string :eof) (return database)) - (let* ((end (length string)) - (i (position '(#\tab #\space) string - :test-not #'char-memq :end end)) - (term nil)) - (declare (type array-index end) - (type (or null array-index) i term)) - (when i ;; else blank line - (case (char string i) - (#\! nil) ;; Comment - skip - ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip - (#\# ;; Include - (setq term (position '(#\tab #\space) string :test #'char-memq - :start i :end end)) - (when (string-equal string "#INCLUDE" :start1 i :end1 term) - (let ((path (merge-pathnames - (string-trim '(#\tab #\space #\") - (subseq string (1+ term))) - (truename stream)))) - (read-resources database path - :key key :test test :test-not test-not)))) - (otherwise - (multiple-value-bind (name-list value) - (parse-resource string i end) - (when name-list - (when key (setq value (funcall key value))) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (add-resource database name-list value)))))))))))) + (declare (type (or string keyword) string)) + (when (eq string :eof) (return database)) + (let* ((end (length string)) + (i (position '(#\tab #\space) string + :test-not #'char-memq :end end)) + (term nil)) + (declare (type array-index end) + (type (or null array-index) i term)) + (when i ;; else blank line + (case (char string i) + (#\! nil) ;; Comment - skip + ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip + (#\# ;; Include + (setq term (position '(#\tab #\space) string :test #'char-memq + :start i :end end)) + (when (string-equal string "#INCLUDE" :start1 i :end1 term) + (let ((path (merge-pathnames + (string-trim '(#\tab #\space #\") + (subseq string (1+ term))) + (truename stream)))) + (read-resources database path + :key key :test test :test-not test-not)))) + (otherwise + (multiple-value-bind (name-list value) + (parse-resource string i end) + (when name-list + (when key (setq value (funcall key value))) + (when + (cond (test (funcall test name-list value)) + (test-not (not (funcall test-not name-list value))) + (t t)) + (add-resource database name-list value)))))))))))) (defun parse-resource (string &optional (start 0) end) ;; Parse a resource specfication string into a list of names and a value ;; string (declare (type string string) - (type array-index start) - (type (or null array-index) end)) + (type array-index start) + (type (or null array-index) end)) (declare (clx-values name-list value)) (do ((i start) (end (or end (length string))) @@ -534,29 +534,29 @@ (name-list)) ((>= i end)) (declare (type array-index end) - (type (or null array-index) i term)) + (type (or null array-index) i term)) (setq term (position '(#\. #\* #\:) string - :test #'char-memq :start i :end end)) + :test #'char-memq :start i :end end)) (case (and term (char string term)) ;; Name seperator (#\. (when (> term i) - (push (subseq string i term) name-list))) + (push (subseq string i term) name-list))) ;; Wildcard seperator (#\* (when (> term i) - (push (subseq string i term) name-list)) - (push '* name-list)) + (push (subseq string i term) name-list)) + (push '* name-list)) ;; Value separator (#\: (push (subseq string i term) name-list) (return - (values - (nreverse name-list) - (string-trim '(#\tab #\space) (subseq string (1+ term)))))) + (values + (nreverse name-list) + (string-trim '(#\tab #\space) (subseq string (1+ term)))))) (otherwise - (return - (values - (nreverse name-list) - (subseq string i term))))) + (return + (values + (nreverse name-list) + (subseq string i term))))) (setq i (1+ term)))) (defun write-resources (database pathname &key write test test-not) @@ -565,29 +565,29 @@ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) - (type (or pathname string stream) pathname) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) + (type (or pathname string stream) pathname) + (type (or null (function (string stream) t)) write) + (type (or null (function (list t) generalized-boolean)) test test-not)) (resource-with-open-file (stream pathname :direction :output) (map-resource database #'(lambda (name-list value stream write test test-not) - (when - (cond (test (funcall test name-list value)) - (test-not (not (funcall test-not name-list value))) - (t t)) - (let ((previous (car name-list))) - (princ previous stream) - (dolist (name (cdr name-list)) - (unless (or (stringable-equal name "*") - (stringable-equal previous "*")) - (write-char #\. stream)) - (setq previous name) - (princ name stream))) - (write-string ": " stream) - (funcall write value stream) - (terpri stream))) + (when + (cond (test (funcall test name-list value)) + (test-not (not (funcall test-not name-list value))) + (t t)) + (let ((previous (car name-list))) + (princ previous stream) + (dolist (name (cdr name-list)) + (unless (or (stringable-equal name "*") + (stringable-equal previous "*")) + (write-char #\. stream)) + (setq previous name) + (princ name stream))) + (write-string ": " stream) + (funcall write value stream) + (terpri stream))) stream (or write #'princ) test test-not)) database) @@ -599,18 +599,18 @@ ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) - (type window window) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) + (type window window) + (type (or null (function (string) t)) key) + (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (let ((string (get-property window :RESOURCE_MANAGER :type :STRING - :result-type 'string - :transform #'xlib::card8->char))) + :result-type 'string + :transform #'xlib::card8->char))) (when string (with-input-from-string (stream string) - (read-resources database stream - :key key :test test :test-not test-not))))) + (read-resources database stream + :key key :test test :test-not test-not))))) (defun set-wm-resources (database window &key write test test-not) ;; Sets the resources associated with the RESOURCE_MANAGER property @@ -619,15 +619,15 @@ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) - (type window window) - (type (or null (function (string stream) t)) write) - (type (or null (function (list t) generalized-boolean)) + (type window window) + (type (or null (function (string stream) t)) write) + (type (or null (function (list t) generalized-boolean)) test test-not)) (xlib::set-string-property window :RESOURCE_MANAGER (with-output-to-string (stream) (write-resources database stream :write write - :test test :test-not test-not)))) + :test test :test-not test-not)))) (defun root-resources (screen &key database key test test-not) "Returns a resource database containing the contents of the root window @@ -642,15 +642,15 @@ value given to TEST or TEST-NOT." (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (string) t)) key) - (type (or null (function (list t) generalized-boolean)) test test-not) - (clx-values resource-database)) + (type (or null resource-database) database) + (type (or null (function (string) t)) key) + (type (or null (function (list t) generalized-boolean)) test test-not) + (clx-values resource-database)) (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen)) - (database (or database (make-resource-database)))) + (display-default-screen screen) + screen)) + (window (screen-root screen)) + (database (or database (make-resource-database)))) (wm-resources database window :key key :test test :test-not test-not) database)) @@ -664,16 +664,16 @@ string stored in the property." (declare (type (or screen display) screen) - (type (or null resource-database) database) - (type (or null (function (list t) generalized-boolean)) test test-not) - (type (or null (function (string stream) t)) write) - (clx-values resource-database)) + (type (or null resource-database) database) + (type (or null (function (list t) generalized-boolean)) test test-not) + (type (or null (function (string stream) t)) write) + (clx-values resource-database)) (let* ((screen (if (type? screen 'display) - (display-default-screen screen) - screen)) - (window (screen-root screen))) + (display-default-screen screen) + screen)) + (window (screen-root screen))) (set-wm-resources database window - :write write :test test :test-not test-not) + :write write :test test :test-not test-not) database)) (defsetf root-resources (screen &key test test-not (write #'princ))(database) @@ -685,16 +685,16 @@ ;; code. (declare (type display display)) (let ((rdb (make-resource-database)) - (rootwin (screen-root (car (display-roots display))))) + (rootwin (screen-root (car (display-roots display))))) ;; First read the server defaults if present, otherwise from the default ;; resource file (if (get-property rootwin :RESOURCE_MANAGER) - (xlib:wm-resources rdb rootwin) + (xlib:wm-resources rdb rootwin) (let ((path (default-resources-pathname))) - (when (and path (probe-file path)) - (read-resources rdb path)))) + (when (and path (probe-file path)) + (read-resources rdb path)))) ;; Next read from the resources file (let ((path (resources-pathname))) (when (and path (probe-file path)) - (read-resources rdb path))) + (read-resources rdb path))) (setf (display-xdefaults display) rdb))) diff --git a/src/clx/screensaver.lisp b/src/clx/screensaver.lisp index 3605d03e5..42dcf48b0 100644 --- a/src/clx/screensaver.lisp +++ b/src/clx/screensaver.lisp @@ -33,8 +33,8 @@ (in-package :xlib) (export '(screen-saver-query-version - screen-saver-query-info - screen-saver-get-idle) + screen-saver-query-info + screen-saver-get-idle) :xlib) (define-extension "MIT-SCREEN-SAVER") diff --git a/src/clx/sockcl.lisp b/src/clx/sockcl.lisp index 26c0eda34..67ac2ef05 100644 --- a/src/clx/sockcl.lisp +++ b/src/clx/sockcl.lisp @@ -31,33 +31,33 @@ ;;; directory is located. ;;; (CLINES " -enum smmode { /* stream mode */ - smm_input, /* input */ - smm_output, /* output */ - smm_io, /* input-output */ - smm_probe, /* probe */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_user_defined /* for user defined */ +enum smmode { /* stream mode */ + smm_input, /* input */ + smm_output, /* output */ + smm_io, /* input-output */ + smm_probe, /* probe */ + smm_synonym, /* synonym */ + smm_broadcast, /* broadcast */ + smm_concatenated, /* concatenated */ + smm_two_way, /* two way */ + smm_echo, /* echo */ + smm_string_input, /* string input */ + smm_string_output, /* string output */ + smm_user_defined /* for user defined */ }; ") #-akcl (CLINES " struct stream { - short t, m; - FILE *sm_fp; /* file pointer */ - object sm_object0; /* some object */ - object sm_object1; /* some object */ - int sm_int0; /* some int */ - int sm_int1; /* some int */ - short sm_mode; /* stream mode */ - /* of enum smmode */ + short t, m; + FILE *sm_fp; /* file pointer */ + object sm_object0; /* some object */ + object sm_object1; /* some object */ + int sm_int0; /* some int */ + int sm_int1; /* some int */ + short sm_mode; /* stream mode */ + /* of enum smmode */ }; ") @@ -70,10 +70,10 @@ struct stream { (CLINES " int konnect_to_server(host,display) - object host; /* host name */ - int display; /* display number */ + object host; /* host name */ + int display; /* display number */ { - int fd; /* file descriptor */ + int fd; /* file descriptor */ int i; char hname[BUFSIZ]; FILE *fout, *fin; @@ -98,15 +98,15 @@ konnect_to_server(host,display) (CLINES " object konnect_stream(host,fd,flag,elem) - object host; /* not really used */ - int fd; /* file descriptor */ - int flag; /* 0 input, 1 output */ - object elem; /* 'string-char */ + object host; /* not really used */ + int fd; /* file descriptor */ + int flag; /* 0 input, 1 output */ + object elem; /* 'string-char */ { struct stream *stream; - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - enum smmode smm; /* lisp mode (a short) */ + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + enum smmode smm; /* lisp mode (a short) */ vs_mark; switch(flag){ @@ -148,16 +148,16 @@ konnect_stream(host,fd,flag,elem) ;;;; Open an X stream (defun open-socket-stream (host display) - (when (not (and (typep host 'string) ; sanity check the arguments - (typep display 'fixnum))) + (when (not (and (typep host 'string) ; sanity check the arguments + (typep display 'fixnum))) (error "Host ~s or display ~s are bad." host display)) - (let ((fd (konnect-to-server host display))) ; get a file discriptor + (let ((fd (konnect-to-server host display))) ; get a file discriptor (if (< fd 0) - NIL - (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input - (stream-out (konnect-stream host fd 1 'string-char))) ; output - (if (or (null stream-in) (null stream-out)) - (error "Could not make i/o streams for fd ~d." fd)) - (make-two-way-stream stream-in stream-out)) - ))) + NIL + (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input + (stream-out (konnect-stream host fd 1 'string-char))) ; output + (if (or (null stream-in) (null stream-out)) + (error "Could not make i/o streams for fd ~d." fd)) + (make-two-way-stream stream-in stream-out)) + ))) diff --git a/src/clx/socket.c b/src/clx/socket.c index b2eaf39d5..250027c4d 100644 --- a/src/clx/socket.c +++ b/src/clx/socket.c @@ -1,4 +1,4 @@ -/* Copyright Massachusetts Institute of Technology 1988 */ +/* Copyright Massachusetts Institute of Technology 1988 */ /* * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived * systems. VMS and System V should plan to have their own version. @@ -20,8 +20,8 @@ #include #endif -extern int errno; /* Certain (broken) OS's don't have this */ - /* decl in errno.h */ +extern int errno; /* Certain (broken) OS's don't have this */ + /* decl in errno.h */ #ifdef UNIXCONN #include @@ -48,74 +48,74 @@ int connect_to_server (host, display) char *host; int display; { - struct sockaddr_in inaddr; /* INET socket address. */ - struct sockaddr *addr; /* address to connect to */ + struct sockaddr_in inaddr; /* INET socket address. */ + struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; - int addrlen; /* length of address */ + int addrlen; /* length of address */ #ifdef UNIXCONN - struct sockaddr_un unaddr; /* UNIX socket address. */ + struct sockaddr_un unaddr; /* UNIX socket address. */ #endif extern char *getenv(); extern struct hostent *gethostbyname(); - int fd; /* Network socket */ + int fd; /* Network socket */ { #ifdef UNIXCONN if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { - /* Connect locally using Unix domain. */ - unaddr.sun_family = AF_UNIX; - (void) strcpy(unaddr.sun_path, X_UNIX_PATH); - (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); - addr = (struct sockaddr *) &unaddr; - addrlen = strlen(unaddr.sun_path) + 2; - /* - * Open the network connection. - */ - if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { + /* Connect locally using Unix domain. */ + unaddr.sun_family = AF_UNIX; + (void) strcpy(unaddr.sun_path, X_UNIX_PATH); + (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); + addr = (struct sockaddr *) &unaddr; + addrlen = strlen(unaddr.sun_path) + 2; + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { #ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ - if (errno == ENOENT) { /* No such file or directory */ - (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); + if (errno == ENOENT) { /* No such file or directory */ + (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); addrlen = strlen(unaddr.sun_path) + 2; if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) return(-1); /* errno set by most recent system call. */ - } else + } else #endif /* hpux */ - return(-1); /* errno set by system call. */ + return(-1); /* errno set by system call. */ } } else #endif /* UNIXCONN */ { /* Get the statistics on the specified host. */ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) - { - if ((host_ptr = gethostbyname(host)) == NULL) - { - /* No such host! */ - errno = EINVAL; - return(-1); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) - { - /* Not an Internet host! */ - errno = EPROTOTYPE; - return(-1); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; + { + if ((host_ptr = gethostbyname(host)) == NULL) + { + /* No such host! */ + errno = EINVAL; + return(-1); + } + /* Check the address type for an internet host. */ + if (host_ptr->h_addrtype != AF_INET) + { + /* Not an Internet host! */ + errno = EPROTOTYPE; + return(-1); + } + /* Set up the socket data. */ + inaddr.sin_family = host_ptr->h_addrtype; #ifdef hpux - (void) memcpy((char *)&inaddr.sin_addr, - (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); + (void) memcpy((char *)&inaddr.sin_addr, + (char *)host_ptr->h_addr, + sizeof(inaddr.sin_addr)); #else /* hpux */ - (void) bcopy((char *)host_ptr->h_addr, - (char *)&inaddr.sin_addr, - sizeof(inaddr.sin_addr)); + (void) bcopy((char *)host_ptr->h_addr, + (char *)&inaddr.sin_addr, + sizeof(inaddr.sin_addr)); #endif /* hpux */ - } + } else - { - inaddr.sin_family = AF_INET; - } + { + inaddr.sin_family = AF_INET; + } addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); inaddr.sin_port = display + X_TCP_PORT; @@ -124,12 +124,12 @@ int connect_to_server (host, display) * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ - return(-1); /* errno set by system call. */} + return(-1); /* errno set by system call. */} /* make sure to turn off TCP coalescence */ #ifdef TCP_NODELAY { - int mi = 1; - setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); + int mi = 1; + setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); } #endif } @@ -137,13 +137,13 @@ int connect_to_server (host, display) /* * Changed 9/89 to retry connection if system call was interrupted. This * is necessary for multiprocessing implementations that use timers, - * since the timer results in a SIGALRM. -- jdi + * since the timer results in a SIGALRM. -- jdi */ while (connect(fd, addr, addrlen) == -1) { - if (errno != EINTR) { - (void) close (fd); - return(-1); /* errno set by system call. */ - } + if (errno != EINTR) { + (void) close (fd); + return(-1); /* errno set by system call. */ + } } } /* diff --git a/src/clx/test/image.lisp b/src/clx/test/image.lisp index 15dae1f0c..367b983e9 100644 --- a/src/clx/test/image.lisp +++ b/src/clx/test/image.lisp @@ -28,52 +28,52 @@ (defun image-test (&key - (host *image-test-host*) - (nimages *image-test-nimages*) - (copy *image-test-copy*) - (copy-random-subimage *image-test-copy-random-subimage*) - (put-random-subimage *image-test-put-random-subimage*) - (get-image-result-type-choices - *image-test-get-image-result-type-choices*) - (get-image-image-x-format-choices - *image-test-get-image-image-x-format-choices*)) + (host *image-test-host*) + (nimages *image-test-nimages*) + (copy *image-test-copy*) + (copy-random-subimage *image-test-copy-random-subimage*) + (put-random-subimage *image-test-put-random-subimage*) + (get-image-result-type-choices + *image-test-get-image-result-type-choices*) + (get-image-image-x-format-choices + *image-test-get-image-image-x-format-choices*)) (declare (ignore host)) (let* ((display nil) - (abort t) - (images nil)) + (abort t) + (images nil)) (loop (setq images nil) (unwind-protect - (progn - (setq display (open-default-display)) - (let* ((screen (display-default-screen display)) - (window (screen-root screen)) - (gcontext (create-gcontext - :foreground (screen-white-pixel screen) - :background (screen-black-pixel screen) - :drawable window - :font (open-font display "fixed")))) - (dotimes (i nimages) - (let ((image (image-test-get-image - window - get-image-result-type-choices - get-image-image-x-format-choices))) - (format t "~&Image=~S~%" image) - (let ((copy (if copy - (image-test-copy-image - image - copy-random-subimage) - image))) - (format t "~&Copy=~S~%" copy) - (push (list image copy) images) - (image-test-put-image - screen gcontext copy - (concatenate - 'string (image-info image) (image-info copy)) - put-random-subimage)))) - (unless (y-or-n-p "More ") (return)) - (setq abort nil))) - (close-display (shiftf display nil) :abort abort)) + (progn + (setq display (open-default-display)) + (let* ((screen (display-default-screen display)) + (window (screen-root screen)) + (gcontext (create-gcontext + :foreground (screen-white-pixel screen) + :background (screen-black-pixel screen) + :drawable window + :font (open-font display "fixed")))) + (dotimes (i nimages) + (let ((image (image-test-get-image + window + get-image-result-type-choices + get-image-image-x-format-choices))) + (format t "~&Image=~S~%" image) + (let ((copy (if copy + (image-test-copy-image + image + copy-random-subimage) + image))) + (format t "~&Copy=~S~%" copy) + (push (list image copy) images) + (image-test-put-image + screen gcontext copy + (concatenate + 'string (image-info image) (image-info copy)) + put-random-subimage)))) + (unless (y-or-n-p "More ") (return)) + (setq abort nil))) + (close-display (shiftf display nil) :abort abort)) (sleep 10)) (reverse images))) @@ -82,19 +82,19 @@ (defun image-test-get-image (window result-type-choices image-x-format-choices) (let* ((x (random (floor (drawable-width window) 3))) - (y (random (floor (drawable-height window) 3))) - (hw (floor (- (drawable-width window) x) 3)) - (hh (floor (- (drawable-height window) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh))) - (result-type (image-test-choose result-type-choices)) - (format - (ecase result-type - (image-x (image-test-choose image-x-format-choices)) - (image-xy :xy-pixmap) - (image-z :z-pixmap))) - (image (get-image window :x x :y y :width width :height height - :format format :result-type result-type))) + (y (random (floor (drawable-height window) 3))) + (hw (floor (- (drawable-width window) x) 3)) + (hh (floor (- (drawable-height window) y) 3)) + (width (+ hw hw (random hw))) + (height (+ hh hh (random hh))) + (result-type (image-test-choose result-type-choices)) + (format + (ecase result-type + (image-x (image-test-choose image-x-format-choices)) + (image-xy :xy-pixmap) + (image-z :z-pixmap))) + (image (get-image window :x x :y y :width width :height height + :format format :result-type result-type))) (setf (getf (image-plist image) :root-x) x) (setf (getf (image-plist image) :root-y) y) image)) @@ -102,59 +102,59 @@ (defun image-test-subimage-parameters (image random-subimage-p) (if random-subimage-p (let* ((x (random (floor (image-width image) 3))) - (y (random (floor (image-height image) 3))) - (hw (floor (- (image-width image) x) 3)) - (hh (floor (- (image-height image) y) 3)) - (width (+ hw hw (random hw))) - (height (+ hh hh (random hh)))) - (values x y width height)) + (y (random (floor (image-height image) 3))) + (hw (floor (- (image-width image) x) 3)) + (hh (floor (- (image-height image) y) 3)) + (width (+ hw hw (random hw))) + (height (+ hh hh (random hh)))) + (values x y width height)) (values 0 0 (image-width image) (image-height image)))) (defun image-test-copy-image (image random-subimage-p) (let ((result-type - (if (zerop (random 2)) - (type-of image) - (etypecase image - (image-x (ecase (image-x-format image) - (:xy-pixmap 'image-xy) - (:z-pixmap 'image-z))) - ((or image-xy image-z) 'image-x))))) + (if (zerop (random 2)) + (type-of image) + (etypecase image + (image-x (ecase (image-x-format image) + (:xy-pixmap 'image-xy) + (:z-pixmap 'image-z))) + ((or image-xy image-z) 'image-x))))) (multiple-value-bind (x y width height) - (image-test-subimage-parameters image random-subimage-p) + (image-test-subimage-parameters image random-subimage-p) (incf (getf (image-plist image) :root-x) x) (incf (getf (image-plist image) :root-y) y) (copy-image image :x x :y y :width width :height height - :result-type result-type)))) + :result-type result-type)))) (defun image-test-put-image (screen gcontext image info random-subimage-p) (multiple-value-bind (src-x src-y width height) (image-test-subimage-parameters image random-subimage-p) (let* ((border-width 1) - (root-x (getf (image-plist image) :root-x)) - (root-y (getf (image-plist image) :root-y)) - (x (+ src-x root-x (- border-width))) - (y (+ src-y root-y (- border-width)))) + (root-x (getf (image-plist image) :root-x)) + (root-y (getf (image-plist image) :root-y)) + (x (+ src-x root-x (- border-width))) + (y (+ src-y root-y (- border-width)))) (unless (or (zerop width) (zerop height)) - (let ((window - (create-window - :parent (screen-root screen) :x x :y y - :width width :height height - :border-width border-width - :background (screen-white-pixel screen) - :override-redirect :on))) - (map-window window) - (display-finish-output (drawable-display window)) - (put-image window gcontext image - :x 0 :y 0 :src-x src-x :src-y src-y - :width width :height height) - (draw-image-glyphs window gcontext 0 (1- height) info) - (display-finish-output (drawable-display window)) - window))))) + (let ((window + (create-window + :parent (screen-root screen) :x x :y y + :width width :height height + :border-width border-width + :background (screen-white-pixel screen) + :override-redirect :on))) + (map-window window) + (display-finish-output (drawable-display window)) + (put-image window gcontext image + :x 0 :y 0 :src-x src-x :src-y src-y + :width width :height height) + (draw-image-glyphs window gcontext 0 (1- height) info) + (display-finish-output (drawable-display window)) + window))))) (defun image-info (image) (etypecase image (image-x (ecase (image-x-format image) - (:xy-pixmap "XXY") - (:z-pixmap "XZ "))) + (:xy-pixmap "XXY") + (:z-pixmap "XZ "))) (image-xy "XY ") (image-z "Z "))) diff --git a/src/clx/test/trapezoid.lisp b/src/clx/test/trapezoid.lisp index ff9594258..8952a2a94 100644 --- a/src/clx/test/trapezoid.lisp +++ b/src/clx/test/trapezoid.lisp @@ -3,9 +3,9 @@ ;;; CLX trapezoid Extension test program ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -24,49 +24,49 @@ (defun zoid-test () ;; Display the part picture in /extensions/test/datafile (let* ((display (open-default-display)) - (width 400) - (height 400) - (screen (display-default-screen display)) - (black (screen-black-pixel screen)) - (white (screen-white-pixel screen)) - (win (create-window - :parent (screen-root screen) - :background black - :border white - :border-width 1 - :colormap (screen-default-colormap screen) - :bit-gravity :center - :event-mask '(:exposure :key-press) - :x 20 :y 20 - :width width :height height)) - (gc (create-gcontext - :drawable win - :background black - :foreground white))) + (width 400) + (height 400) + (screen (display-default-screen display)) + (black (screen-black-pixel screen)) + (white (screen-white-pixel screen)) + (win (create-window + :parent (screen-root screen) + :background black + :border white + :border-width 1 + :colormap (screen-default-colormap screen) + :bit-gravity :center + :event-mask '(:exposure :key-press) + :x 20 :y 20 + :width width :height height)) + (gc (create-gcontext + :drawable win + :background black + :foreground white))) (initialize-extensions display) - (map-window win) ; Map the window + (map-window win) ; Map the window ;; Handle events (unwind-protect - (loop - (event-case (display :force-output-p t) - (exposure ;; Come here on exposure events - (window count) - (when (zerop count) ;; Ignore all but the last exposure event - (clear-area window) - ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES - (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) - (setf (gcontext-trapezoid-alignment gc) :y) - (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) - (with-gcontext (gc :trapezoid-alignment :x) - (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) - (setf (gcontext-trapezoid-alignment gc) :x) - (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) - (with-gcontext (gc :trapezoid-alignment :y) - (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) - - (draw-glyphs window gc 10 10 "Press any key to exit") - ;; Returning non-nil causes event-case to exit - t)) - (key-press () (return-from zoid-test t)))) + (loop + (event-case (display :force-output-p t) + (exposure ;; Come here on exposure events + (window count) + (when (zerop count) ;; Ignore all but the last exposure event + (clear-area window) + ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES + (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) + (setf (gcontext-trapezoid-alignment gc) :y) + (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) + (with-gcontext (gc :trapezoid-alignment :x) + (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) + (setf (gcontext-trapezoid-alignment gc) :x) + (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) + (with-gcontext (gc :trapezoid-alignment :y) + (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) + + (draw-glyphs window gc 10 10 "Press any key to exit") + ;; Returning non-nil causes event-case to exit + t)) + (key-press () (return-from zoid-test t)))) (close-display display)))) diff --git a/src/clx/text.lisp b/src/clx/text.lisp index 08c9973a7..167c0c418 100644 --- a/src/clx/text.lisp +++ b/src/clx/text.lisp @@ -3,9 +3,9 @@ ;;; CLX text keyboard and pointer requests ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -34,7 +34,7 @@ #+explorer t #-explorer '(function (sequence array-index array-index (or null font) vector array-index) - (values array-index (or null int16 font) (or null int32)))) + (values array-index (or null int16 font) (or null int32)))) ;; In the functions below, if width is specified, it is assumed to be the pixel ;; width of whatever string of glyphs is actually drawn. Specifying width will @@ -64,39 +64,39 @@ ;; (OR null horizontal-motion font) ;; (OR null translated-width)) (declare (type sequence src) - (type array-index src-start src-end dst-start) - (type (or null font) font) - (type vector dst) - (inline graphic-char-p)) + (type array-index src-start src-end dst-start) + (type (or null font) font) + (type vector dst) + (inline graphic-char-p)) (declare (clx-values integer (or null integer font) (or null integer))) (let ((min-char-index (and font (xlib:font-min-char font))) (max-char-index (and font (xlib:font-max-char font)))) (if (stringp src) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (char)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setf char (char->card8 (char src i))) - (if (and font (or (< char min-char-index) (> char max-char-index))) - (return i) - (setf (aref dst j) char))) - (do ((i src-start (index+ i 1)) - (j dst-start (index+ j 1)) - (elt)) - ((index>= i src-end) - i) - (declare (type array-index i j)) - (setq elt (elt src i)) - (when (characterp elt) (setq elt (char->card8 elt))) - (if (or (not (integerp elt)) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (char)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setf char (char->card8 (char src i))) + (if (and font (or (< char min-char-index) (> char max-char-index))) + (return i) + (setf (aref dst j) char))) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (elt)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setq elt (elt src i)) + (when (characterp elt) (setq elt (char->card8 elt))) + (if (or (not (integerp elt)) (and font (< elt min-char-index) (> elt max-char-index))) - (return i) - (setf (aref dst j) elt)))))) + (return i) + (setf (aref dst j) elt)))))) ;; There is a question below of whether translate should always be required, or ;; if not, what the default should be or where it should come from. For @@ -112,324 +112,324 @@ ;; maximums. If multiple directions are involved, the direction will be nil. ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) - (type (or font gcontext) font)) + (type (or font gcontext) font)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values width ascent descent left right - font-ascent font-descent direction - (or null array-index))) + font-ascent font-descent direction + (or null array-index))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((left-bearing 0) - (right-bearing 0) - ;; Sum of widths - (width 0) - (ascent 0) - (descent 0) - (overall-ascent (font-ascent font)) - (overall-descent (font-descent font)) - (overall-direction (font-direction font)) - (next-start nil) - (display (font-display font))) + (right-bearing 0) + ;; Sum of widths + (width 0) + (ascent 0) + (descent 0) + (overall-ascent (font-ascent font)) + (overall-descent (font-descent font)) + (overall-direction (font-direction font)) + (next-start nil) + (display (font-display font))) (declare (type int16 ascent descent overall-ascent overall-descent) - (type int32 left-bearing right-bearing width) - (type (or null array-index) next-start) - (type display display)) + (type int32 left-bearing right-bearing width) + (type (or null array-index) next-start) + (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (font-ascent 0) - (font-descent 0) - (font-direction) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type int16 font-ascent font-descent) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (let (w a d l r) - (if (or (font-char-infos-internal font) (font-local-only-p font)) - ;; Calculate text extents locally - (progn - (multiple-value-setq (w a d l r) - (text-extents-local font wbuf 0 buf-end nil)) - (setq font-ascent (the int16 (font-ascent font)) - font-descent (the int16 (font-descent font)) - font-direction (font-direction font))) - ;; Let the server calculate text extents - (multiple-value-setq - (w a d l r font-ascent font-descent font-direction) - (text-extents-server font wbuf 0 buf-end))) - (incf width (the int32 w)) - (cond ((index= src-start start) - (setq left-bearing (the int32 l)) - (setq right-bearing (the int32 r)) - (setq ascent (the int16 a)) - (setq descent (the int16 d))) - (t - (setq left-bearing (the int32 (min left-bearing (the int32 l)))) - (setq right-bearing (the int32 (max right-bearing (the int32 r)))) - (setq ascent (the int16 (max ascent (the int16 a)))) - (setq descent (the int16 (max descent (the int16 d))))))) + (src-end (or end (length sequence))) + (src-start start (index+ src-start buf-end)) + (end (index-min src-end (index+ src-start +buffer-text16-size+)) + (index-min src-end (index+ src-start +buffer-text16-size+))) + (buf-end 0) + (new-font) + (font-ascent 0) + (font-descent 0) + (font-direction) + (stop-p nil)) + ((or stop-p (index>= src-start src-end)) + (when (index< src-start src-end) + (setq next-start src-start))) + (declare (type buffer-text16 wbuf) + (type array-index src-start src-end end buf-end) + (type int16 font-ascent font-descent) + (type generalized-boolean stop-p)) + ;; Translate the text + (multiple-value-setq (buf-end new-font) + (funcall (or translate #'translate-default) + sequence src-start end font wbuf 0)) + (setq buf-end (- buf-end src-start)) + (cond ((null new-font) (setq stop-p t)) + ((integerp new-font) (incf width (the int32 new-font)))) + + (let (w a d l r) + (if (or (font-char-infos-internal font) (font-local-only-p font)) + ;; Calculate text extents locally + (progn + (multiple-value-setq (w a d l r) + (text-extents-local font wbuf 0 buf-end nil)) + (setq font-ascent (the int16 (font-ascent font)) + font-descent (the int16 (font-descent font)) + font-direction (font-direction font))) + ;; Let the server calculate text extents + (multiple-value-setq + (w a d l r font-ascent font-descent font-direction) + (text-extents-server font wbuf 0 buf-end))) + (incf width (the int32 w)) + (cond ((index= src-start start) + (setq left-bearing (the int32 l)) + (setq right-bearing (the int32 r)) + (setq ascent (the int16 a)) + (setq descent (the int16 d))) + (t + (setq left-bearing (the int32 (min left-bearing (the int32 l)))) + (setq right-bearing (the int32 (max right-bearing (the int32 r)))) + (setq ascent (the int16 (max ascent (the int16 a)))) + (setq descent (the int16 (max descent (the int16 d))))))) - (when (type? new-font 'font) - (setq font new-font)) + (when (type? new-font 'font) + (setq font new-font)) - (setq overall-ascent (the int16 (max overall-ascent font-ascent))) - (setq overall-descent (the int16 (max overall-descent font-descent))) - (case overall-direction - (:unknown (setq overall-direction font-direction)) - (:left-to-right (unless (eq font-direction :left-to-right) - (setq overall-direction nil))) - (:right-to-left (unless (eq font-direction :right-to-left) - (setq overall-direction nil)))))) + (setq overall-ascent (the int16 (max overall-ascent font-ascent))) + (setq overall-descent (the int16 (max overall-descent font-descent))) + (case overall-direction + (:unknown (setq overall-direction font-direction)) + (:left-to-right (unless (eq font-direction :left-to-right) + (setq overall-direction nil))) + (:right-to-left (unless (eq font-direction :right-to-left) + (setq overall-direction nil)))))) (values width - ascent - descent - left-bearing - right-bearing - overall-ascent - overall-descent - overall-direction - next-start))) + ascent + descent + left-bearing + right-bearing + overall-ascent + overall-descent + overall-direction + next-start))) (defun text-width (font sequence &key (start 0) end translate) ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) - (type (or font gcontext) font) - (type array-index start) - (type (or null array-index) end)) + (type (or font gcontext) font) + (type array-index start) + (type (or null array-index) end)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((width 0) - (next-start nil) - (display (font-display font))) + (next-start nil) + (display (font-display font))) (declare (type int32 width) - (type (or null array-index) next-start) - (type display display)) + (type (or null array-index) next-start) + (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) - (src-end (or end (length sequence))) - (src-start start (index+ src-start buf-end)) - (end (index-min src-end (index+ src-start +buffer-text16-size+)) - (index-min src-end (index+ src-start +buffer-text16-size+))) - (buf-end 0) - (new-font) - (stop-p nil)) - ((or stop-p (index>= src-start src-end)) - (when (index< src-start src-end) - (setq next-start src-start))) - (declare (type buffer-text16 wbuf) - (type array-index src-start src-end end buf-end) - (type generalized-boolean stop-p)) - ;; Translate the text - (multiple-value-setq (buf-end new-font) - (funcall (or translate #'translate-default) - sequence src-start end font wbuf 0)) - (setq buf-end (- buf-end src-start)) - (cond ((null new-font) (setq stop-p t)) - ((integerp new-font) (incf width (the int32 new-font)))) - - (incf width - (if (or (font-char-infos-internal font) (font-local-only-p font)) - (text-extents-local font wbuf 0 buf-end :width-only) - (text-width-server font wbuf 0 buf-end))) - (when (type? new-font 'font) - (setq font new-font)))) + (src-end (or end (length sequence))) + (src-start start (index+ src-start buf-end)) + (end (index-min src-end (index+ src-start +buffer-text16-size+)) + (index-min src-end (index+ src-start +buffer-text16-size+))) + (buf-end 0) + (new-font) + (stop-p nil)) + ((or stop-p (index>= src-start src-end)) + (when (index< src-start src-end) + (setq next-start src-start))) + (declare (type buffer-text16 wbuf) + (type array-index src-start src-end end buf-end) + (type generalized-boolean stop-p)) + ;; Translate the text + (multiple-value-setq (buf-end new-font) + (funcall (or translate #'translate-default) + sequence src-start end font wbuf 0)) + (setq buf-end (- buf-end src-start)) + (cond ((null new-font) (setq stop-p t)) + ((integerp new-font) (incf width (the int32 new-font)))) + + (incf width + (if (or (font-char-infos-internal font) (font-local-only-p font)) + (text-extents-local font wbuf 0 buf-end :width-only) + (text-width-server font wbuf 0 buf-end))) + (when (type? new-font 'font) + (setq font new-font)))) (values width next-start))) (defun text-extents-server (font sequence start end) (declare (type font font) - (type sequence sequence) - (type array-index start end)) + (type sequence sequence) + (type array-index start end)) (declare (clx-values width ascent descent left right font-ascent font-descent direction)) (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) + (length (index- end start)) + (font-id (font-id font))) (declare (type display display) - (type array-index length) - (type resource-id font-id)) + (type array-index length) + (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) + (((data boolean) (oddp length)) + (length (index+ (index-ceiling length 2) 2)) + (resource-id font-id) + ((sequence :format char2b :start start :end end :appending t) + sequence)) (values - (integer-get 16) - (int16-get 12) - (int16-get 14) - (integer-get 20) - (integer-get 24) - (int16-get 8) - (int16-get 10) - (member8-get 1 :left-to-right :right-to-left))))) + (integer-get 16) + (int16-get 12) + (int16-get 14) + (integer-get 20) + (integer-get 24) + (int16-get 8) + (int16-get 10) + (member8-get 1 :left-to-right :right-to-left))))) (defun text-width-server (font sequence start end) (declare (type (or font gcontext) font) - (type sequence sequence) - (type array-index start end)) + (type sequence sequence) + (type array-index start end)) (declare (clx-values integer)) (let ((display (font-display font)) - (length (index- end start)) - (font-id (font-id font))) + (length (index- end start)) + (font-id (font-id font))) (declare (type display display) - (type array-index length) - (type resource-id font-id)) + (type array-index length) + (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) - (((data boolean) (oddp length)) - (length (index+ (index-ceiling length 2) 2)) - (resource-id font-id) - ((sequence :format char2b :start start :end end :appending t) - sequence)) + (((data boolean) (oddp length)) + (length (index+ (index-ceiling length 2) 2)) + (resource-id font-id) + ((sequence :format char2b :start start :end end :appending t) + sequence)) (values (integer-get 16))))) (defun text-extents-local (font sequence start end width-only-p) (declare (type font font) - (type sequence sequence) - (type integer start end) - (type generalized-boolean width-only-p)) + (type sequence sequence) + (type integer start end) + (type generalized-boolean width-only-p)) (declare (clx-values width ascent descent overall-left overall-right)) (let* ((char-infos (font-char-infos font)) - (font-info (font-font-info font))) + (font-info (font-font-info font))) (declare (type font-info font-info)) (declare (type (simple-array int16 (*)) char-infos)) (if (zerop (length char-infos)) - ;; Fixed width font - (let* ((font-width (max-char-width font)) - (font-ascent (max-char-ascent font)) - (font-descent (max-char-descent font)) - (width (* (index- end start) font-width))) - (declare (type int16 font-width font-ascent font-descent) - (type int32 width)) - (if width-only-p - width - (values width - font-ascent - font-descent - (max-char-left-bearing font) - (+ width (- font-width) (max-char-right-bearing font))))) + ;; Fixed width font + (let* ((font-width (max-char-width font)) + (font-ascent (max-char-ascent font)) + (font-descent (max-char-descent font)) + (width (* (index- end start) font-width))) + (declare (type int16 font-width font-ascent font-descent) + (type int32 width)) + (if width-only-p + width + (values width + font-ascent + font-descent + (max-char-left-bearing font) + (+ width (- font-width) (max-char-right-bearing font))))) ;; Variable-width font (let* ((first-col (font-info-min-byte2 font-info)) - (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) - (first-row (font-info-min-byte1 font-info)) - (last-row (font-info-max-byte1 font-info)) - (num-rows (1+ (- last-row first-row)))) - (declare (type card8 first-col first-row last-row) - (type card16 num-cols num-rows)) - (if (or (plusp first-row) (plusp last-row)) - - ;; Matrix (16 bit) font - (macrolet ((char-info-elt (sequence elt) - `(let* ((char (the card16 (elt ,sequence ,elt))) - (row (- (ash char -8) first-row)) - (col (- (logand char #xff) first-col))) - (declare (type card16 char) - (type int16 row col)) - (if (and (< -1 row num-rows) (< -1 col num-cols)) - (index* 6 (index+ (index* row num-cols) col)) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))))))) - - ;; Non-matrix (8 bit) font - ;; The code here is identical to the above, except for the following macro: - (macrolet ((char-info-elt (sequence elt) - `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) - (declare (type int16 col)) - (if (< -1 col num-cols) - (index* 6 col) - -1)))) - (if width-only-p - (do ((i start (index1+ i)) - (width 0)) - ((index>= i end) width) - (declare (type array-index i) - (type int32 width)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (incf width (the int16 (aref char-infos (index+ 2 n))))))) - ;; extents - (do ((i start (index1+ i)) - (width 0) - (ascent #x-7fff) - (descent #x-7fff) - (left #x7fff) - (right #x-7fff)) - ((index>= i end) - (values width ascent descent left right)) - (declare (type array-index i) - (type int16 ascent descent) - (type int32 width left right)) - (let ((n (char-info-elt sequence i))) - (declare (type fixnum n)) - (unless (minusp n) ;; Ignore characters not in the font - (setq left (min left (+ width (aref char-infos n)))) - (setq right (max right (+ width (aref char-infos (index1+ n))))) - (incf width (aref char-infos (index+ 2 n))) - (setq ascent (max ascent (aref char-infos (index+ 3 n)))) - (setq descent (max descent (aref char-infos (index+ 4 n))))) - )))) - ))))) + (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) + (first-row (font-info-min-byte1 font-info)) + (last-row (font-info-max-byte1 font-info)) + (num-rows (1+ (- last-row first-row)))) + (declare (type card8 first-col first-row last-row) + (type card16 num-cols num-rows)) + (if (or (plusp first-row) (plusp last-row)) + + ;; Matrix (16 bit) font + (macrolet ((char-info-elt (sequence elt) + `(let* ((char (the card16 (elt ,sequence ,elt))) + (row (- (ash char -8) first-row)) + (col (- (logand char #xff) first-col))) + (declare (type card16 char) + (type int16 row col)) + (if (and (< -1 row num-rows) (< -1 col num-cols)) + (index* 6 (index+ (index* row num-cols) col)) + -1)))) + (if width-only-p + (do ((i start (index1+ i)) + (width 0)) + ((index>= i end) width) + (declare (type array-index i) + (type int32 width)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (incf width (the int16 (aref char-infos (index+ 2 n))))))) + ;; extents + (do ((i start (index1+ i)) + (width 0) + (ascent #x-7fff) + (descent #x-7fff) + (left #x7fff) + (right #x-7fff)) + ((index>= i end) + (values width ascent descent left right)) + (declare (type array-index i) + (type int16 ascent descent) + (type int32 width left right)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (setq left (min left (+ width (aref char-infos n)))) + (setq right (max right (+ width (aref char-infos (index1+ n))))) + (incf width (aref char-infos (index+ 2 n))) + (setq ascent (max ascent (aref char-infos (index+ 3 n)))) + (setq descent (max descent (aref char-infos (index+ 4 n))))))))) + + ;; Non-matrix (8 bit) font + ;; The code here is identical to the above, except for the following macro: + (macrolet ((char-info-elt (sequence elt) + `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) + (declare (type int16 col)) + (if (< -1 col num-cols) + (index* 6 col) + -1)))) + (if width-only-p + (do ((i start (index1+ i)) + (width 0)) + ((index>= i end) width) + (declare (type array-index i) + (type int32 width)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (incf width (the int16 (aref char-infos (index+ 2 n))))))) + ;; extents + (do ((i start (index1+ i)) + (width 0) + (ascent #x-7fff) + (descent #x-7fff) + (left #x7fff) + (right #x-7fff)) + ((index>= i end) + (values width ascent descent left right)) + (declare (type array-index i) + (type int16 ascent descent) + (type int32 width left right)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (setq left (min left (+ width (aref char-infos n)))) + (setq right (max right (+ width (aref char-infos (index1+ n))))) + (incf width (aref char-infos (index+ 2 n))) + (setq ascent (max ascent (aref char-infos (index+ 3 n)))) + (setq descent (max descent (aref char-infos (index+ 4 n))))) + )))) + ))))) ;;----------------------------------------------------------------------------- @@ -456,176 +456,176 @@ ;; for performance. (defun draw-glyph (drawable gcontext x y elt - &key translate width (size :default)) + &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) + (type gcontext gcontext) + (type int16 x y) + (type (or null int32) width) + (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-polytext8+)) + (result t) + (opcode +x-polytext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) + (funcall (or translate #'translate-default) + vector 0 1 (gcontext-font gcontext nil) vector 1) + ;; Allow translate to set a new font + (when (type? new-font 'font) + (setf (gcontext-font gcontext) new-font) + (multiple-value-setq (new-start new-font translate-width) + (funcall translate vector 0 1 new-font vector 1))) + ;; If new-start is zero, translate refuses to output it + (setq result (index-plusp new-start) + elt (aref vector 1)) + (deallocate-gcontext-state vector) + (when translate-width (setq width translate-width)))) (when result (when (eql size 16) - (setq opcode +x-polytext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) + (setq opcode +x-polytext16+) + (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (card8 1 0) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (card8 1 0) + (card8 (ldb (byte 8 0) elt)) + (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) + &key (start 0) end translate width (size :default)) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width) - (type index-size size)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width) + (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end - (or translate #'translate-default) width)) + (or translate #'translate-default) width)) (16 (draw-glyphs16 drawable gcontext x y sequence start end - (or translate #'translate-default) width)))) + (or translate #'translate-default) width)))) (defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 2)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil))) + (src-end (or end (length sequence))) + (next-start nil) + (length (index- src-end src-start)) + (request-length (* length 2)) ; Leave lots of room for font shifts. + (display (gcontext-display gcontext)) + (font (gcontext-font gcontext nil))) (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display)) + (type (or null array-index) next-start) + (type display display)) (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (the array-index (lround boffset)))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (index-zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + (do* ((boffset (index+ buffer-boffset 16)) + (src-chunk 0) + (dst-chunk 0) + (offset 0) + (overall-width 0) + (stop-p nil)) + ((or stop-p (zerop length)) + ;; Ensure terminated with zero bytes + (do ((end (the array-index (lround boffset)))) + ((index>= boffset end)) + (setf (aref buffer-bbuf boffset) 0) + (index-incf boffset)) + (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) + (setf (buffer-boffset display) boffset) + (unless (index-zerop length) (setq next-start src-start)) + (when overall-width (setq width overall-width))) - (declare (type array-index src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer-bbuf (index+ boffset 2)) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (incf boffset (index+ dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the server - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) + (declare (type array-index src-chunk dst-chunk offset) + (type (or null int32) overall-width) + (type generalized-boolean stop-p)) + (setq src-chunk (index-min length *max-string-size*)) + (multiple-value-bind (new-start new-font translated-width) + (funcall translate + sequence src-start (index+ src-start src-chunk) + font buffer-bbuf (index+ boffset 2)) + (setq dst-chunk (index- new-start src-start) + length (index- length dst-chunk) + src-start new-start) + (if translated-width + (when overall-width (incf overall-width translated-width)) + (setq overall-width nil)) + (when (index-plusp dst-chunk) + (setf (aref buffer-bbuf boffset) dst-chunk) + (setf (aref buffer-bbuf (index+ boffset 1)) offset) + (incf boffset (index+ dst-chunk 2))) + (setq offset 0) + (cond ((null new-font) + ;; Don't stop if translate copied whole chunk + (unless (index= src-chunk dst-chunk) + (setq stop-p t))) + ((integerp new-font) (setq offset new-font)) + ((type? new-font 'font) + (setq font new-font) + (let ((font-id (font-id font)) + (buffer-boffset boffset)) + (declare (type resource-id font-id) + (type array-index buffer-boffset)) + ;; This changes the gcontext font in the server + ;; Update the gcontext cache (both local and server state) + (let ((local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state local-state server-state)) + (setf (gcontext-internal-font-obj server-state) font + (gcontext-internal-font server-state) font-id) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font + (gcontext-internal-font local-state) font-id))) + (card8-put 0 #xff) + (card8-put 1 (ldb (byte 8 24) font-id)) + (card8-put 2 (ldb (byte 8 16) font-id)) + (card8-put 3 (ldb (byte 8 8) font-id)) + (card8-put 4 (ldb (byte 8 0) font-id))) + (index-incf boffset 5))) + ))))) (values next-start width))) ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer @@ -634,156 +634,156 @@ ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (let* ((src-start start) - (src-end (or end (length sequence))) - (next-start nil) - (length (index- src-end src-start)) - (request-length (* length 3)) ; Leave lots of room for font shifts. - (display (gcontext-display gcontext)) - (font (gcontext-font gcontext nil)) - (buffer (display-tbuf16 display))) + (src-end (or end (length sequence))) + (next-start nil) + (length (index- src-end src-start)) + (request-length (* length 3)) ; Leave lots of room for font shifts. + (display (gcontext-display gcontext)) + (font (gcontext-font gcontext nil)) + (buffer (display-tbuf16 display))) (declare (type array-index src-start src-end length) - (type (or null array-index) next-start) - (type display display) - (type buffer-text16 buffer)) + (type (or null array-index) next-start) + (type display display) + (type buffer-text16 buffer)) (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - (do* ((boffset (index+ buffer-boffset 16)) - (src-chunk 0) - (dst-chunk 0) - (offset 0) - (overall-width 0) - (stop-p nil)) - ((or stop-p (zerop length)) - ;; Ensure terminated with zero bytes - (do ((end (lround boffset))) - ((index>= boffset end)) - (setf (aref buffer-bbuf boffset) 0) - (index-incf boffset)) - (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) - (setf (buffer-boffset display) boffset) - (unless (zerop length) (setq next-start src-start)) - (when overall-width (setq width overall-width))) + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + (do* ((boffset (index+ buffer-boffset 16)) + (src-chunk 0) + (dst-chunk 0) + (offset 0) + (overall-width 0) + (stop-p nil)) + ((or stop-p (zerop length)) + ;; Ensure terminated with zero bytes + (do ((end (lround boffset))) + ((index>= boffset end)) + (setf (aref buffer-bbuf boffset) 0) + (index-incf boffset)) + (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) + (setf (buffer-boffset display) boffset) + (unless (zerop length) (setq next-start src-start)) + (when overall-width (setq width overall-width))) - (declare (type array-index boffset src-chunk dst-chunk offset) - (type (or null int32) overall-width) - (type generalized-boolean stop-p)) - (setq src-chunk (index-min length *max-string-size*)) - (multiple-value-bind (new-start new-font translated-width) - (funcall translate - sequence src-start (index+ src-start src-chunk) - font buffer 0) - (setq dst-chunk (index- new-start src-start) - length (index- length dst-chunk) - src-start new-start) - (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) - (if translated-width - (when overall-width (incf overall-width translated-width)) - (setq overall-width nil)) - (when (index-plusp dst-chunk) - (setf (aref buffer-bbuf boffset) dst-chunk) - (setf (aref buffer-bbuf (index+ boffset 1)) offset) - (index-incf boffset (index+ dst-chunk dst-chunk 2))) - (setq offset 0) - (cond ((null new-font) - ;; Don't stop if translate copied whole chunk - (unless (index= src-chunk dst-chunk) - (setq stop-p t))) - ((integerp new-font) (setq offset new-font)) - ((type? new-font 'font) - (setq font new-font) - (let ((font-id (font-id font)) - (buffer-boffset boffset)) - (declare (type resource-id font-id) - (type array-index buffer-boffset)) - ;; This changes the gcontext font in the SERVER - ;; Update the gcontext cache (both local and server state) - (let ((local-state (gcontext-local-state gcontext)) - (server-state (gcontext-server-state gcontext))) - (declare (type gcontext-state local-state server-state)) - (setf (gcontext-internal-font-obj server-state) font - (gcontext-internal-font server-state) font-id) - (without-interrupts - (setf (gcontext-internal-font-obj local-state) font - (gcontext-internal-font local-state) font-id))) - (card8-put 0 #xff) - (card8-put 1 (ldb (byte 8 24) font-id)) - (card8-put 2 (ldb (byte 8 16) font-id)) - (card8-put 3 (ldb (byte 8 8) font-id)) - (card8-put 4 (ldb (byte 8 0) font-id))) - (index-incf boffset 5))) - ))))) + (declare (type array-index boffset src-chunk dst-chunk offset) + (type (or null int32) overall-width) + (type generalized-boolean stop-p)) + (setq src-chunk (index-min length *max-string-size*)) + (multiple-value-bind (new-start new-font translated-width) + (funcall translate + sequence src-start (index+ src-start src-chunk) + font buffer 0) + (setq dst-chunk (index- new-start src-start) + length (index- length dst-chunk) + src-start new-start) + (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) + (if translated-width + (when overall-width (incf overall-width translated-width)) + (setq overall-width nil)) + (when (index-plusp dst-chunk) + (setf (aref buffer-bbuf boffset) dst-chunk) + (setf (aref buffer-bbuf (index+ boffset 1)) offset) + (index-incf boffset (index+ dst-chunk dst-chunk 2))) + (setq offset 0) + (cond ((null new-font) + ;; Don't stop if translate copied whole chunk + (unless (index= src-chunk dst-chunk) + (setq stop-p t))) + ((integerp new-font) (setq offset new-font)) + ((type? new-font 'font) + (setq font new-font) + (let ((font-id (font-id font)) + (buffer-boffset boffset)) + (declare (type resource-id font-id) + (type array-index buffer-boffset)) + ;; This changes the gcontext font in the SERVER + ;; Update the gcontext cache (both local and server state) + (let ((local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state local-state server-state)) + (setf (gcontext-internal-font-obj server-state) font + (gcontext-internal-font server-state) font-id) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font + (gcontext-internal-font local-state) font-id))) + (card8-put 0 #xff) + (card8-put 1 (ldb (byte 8 24) font-id)) + (card8-put 2 (ldb (byte 8 16) font-id)) + (card8-put 3 (ldb (byte 8 8) font-id)) + (card8-put 4 (ldb (byte 8 0) font-id))) + (index-incf boffset 5))) + ))))) (values next-start width))) (defun draw-image-glyph (drawable gcontext x y elt - &key translate width (size :default)) + &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is overall width, if known. An initial font change is ;; allowed from translate. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type (or null int32) width) - (type index-size size)) + (type gcontext gcontext) + (type int16 x y) + (type (or null int32) width) + (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) - (result t) - (opcode +x-imagetext8+)) + (result t) + (opcode +x-imagetext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) - (funcall (or translate #'translate-default) - vector 0 1 (gcontext-font gcontext nil) vector 1) - ;; Allow translate to set a new font - (when (type? new-font 'font) - (setf (gcontext-font gcontext) new-font) - (multiple-value-setq (new-start new-font translate-width) - (funcall translate vector 0 1 new-font vector 1))) - ;; If new-start is zero, translate refuses to output it - (setq result (index-plusp new-start) - elt (aref vector 1)) - (deallocate-gcontext-state vector) - (when translate-width (setq width translate-width)))) + (funcall (or translate #'translate-default) + vector 0 1 (gcontext-font gcontext nil) vector 1) + ;; Allow translate to set a new font + (when (type? new-font 'font) + (setf (gcontext-font gcontext) new-font) + (multiple-value-setq (new-start new-font translate-width) + (funcall translate vector 0 1 new-font vector 1))) + ;; If new-start is zero, translate refuses to output it + (setq result (index-plusp new-start) + elt (aref vector 1)) + (deallocate-gcontext-state vector) + (when translate-width (setq width translate-width)))) (when result (when (eql size 16) - (setq opcode +x-imagetext16+) - (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) + (setq opcode +x-imagetext16+) + (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) - (drawable drawable) - (gcontext gcontext) - (data 1) ;; 1 character - (int16 x y) - (card8 (ldb (byte 8 0) elt)) - (card8 (ldb (byte 8 8) elt))) + (drawable drawable) + (gcontext gcontext) + (data 1) ;; 1 character + (int16 x y) + (card8 (ldb (byte 8 0) elt)) + (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-image-glyphs (drawable gcontext x y sequence - &key (start 0) end translate width (size :default)) + &key (start 0) end translate width (size :default)) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted @@ -792,18 +792,18 @@ ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type (or null array-index) end) - (type sequence sequence) - (type (or null int32) width) - (type index-size size)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type (or null array-index) end) + (type sequence sequence) + (type (or null int32) width) + (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size @@ -821,61 +821,61 @@ ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk)) + (length (index- end start)) + (font (gcontext-font gcontext nil)) + (font-change nil) + (new-start) (translated-width) (chunk)) (nil) ;; forever (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk)) + (type array-index length) + (type (or null array-index) new-start chunk)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer-bbuf (index+ buffer-boffset 16))) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs8 new-start)) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 chunk)))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + ;; Translate the sequence into the buffer + (multiple-value-setq (new-start font translated-width) + (funcall (or translate #'translate-default) sequence start end + font buffer-bbuf (index+ buffer-boffset 16))) + ;; Number of glyphs translated + (setq chunk (index- new-start start)) + ;; Check for initial font change + (when (and (index-zerop chunk) (type? font 'font)) + (setq font-change t) ;; Loop around changing font + (return-from change-font)) + ;; Quit when nothing translated + (when (index-zerop chunk) + (return-from draw-image-glyphs8 new-start)) + ;; Update buffer pointers + (data-put 1 chunk) + (let ((blen (lround (index+ 16 chunk)))) + (length-put 2 (index-ash blen -2)) + (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs8 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) + (values (if (index= chunk length) nil new-start) + (or translated-width width)))))) (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) ;; An initial font change is allowed from translate, but any subsequent font @@ -886,65 +886,65 @@ ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) - (type gcontext gcontext) - (type int16 x y) - (type array-index start) - (type sequence sequence) - (type (or null array-index) end) - (type (or null int32) width)) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + #+clx-ansi-common-lisp + (dynamic-extent translate) + #+(and lispm (not clx-ansi-common-lisp)) + (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) - (length (index- end start)) - (font (gcontext-font gcontext nil)) - (font-change nil) - (new-start) (translated-width) (chunk) - (buffer (buffer-tbuf16 display))) + (length (index- end start)) + (font (gcontext-font gcontext nil)) + (font-change nil) + (new-start) (translated-width) (chunk) + (buffer (buffer-tbuf16 display))) (nil) ;; forever (declare (type display display) - (type array-index length) - (type (or null array-index) new-start chunk) - (type buffer-text16 buffer)) + (type array-index length) + (type (or null array-index) new-start chunk) + (type buffer-text16 buffer)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) - (drawable drawable) - (gcontext gcontext) - (int16 x y) - (progn - ;; Don't let any flushes happen since we manually set the request - ;; length when we're done. - (with-buffer-flush-inhibited (display) - ;; Translate the sequence into the buffer - (multiple-value-setq (new-start font translated-width) - (funcall (or translate #'translate-default) sequence start end - font buffer 0)) - ;; Number of glyphs translated - (setq chunk (index- new-start start)) - ;; Check for initial font change - (when (and (index-zerop chunk) (type? font 'font)) - (setq font-change t) ;; Loop around changing font - (return-from change-font)) - ;; Quit when nothing translated - (when (index-zerop chunk) - (return-from draw-image-glyphs16 new-start)) - (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) - ;; Update buffer pointers - (data-put 1 chunk) - (let ((blen (lround (index+ 16 (index-ash chunk 1))))) - (length-put 2 (index-ash blen -2)) - (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + ;; Translate the sequence into the buffer + (multiple-value-setq (new-start font translated-width) + (funcall (or translate #'translate-default) sequence start end + font buffer 0)) + ;; Number of glyphs translated + (setq chunk (index- new-start start)) + ;; Check for initial font change + (when (and (index-zerop chunk) (type? font 'font)) + (setq font-change t) ;; Loop around changing font + (return-from change-font)) + ;; Quit when nothing translated + (when (index-zerop chunk) + (return-from draw-image-glyphs16 new-start)) + (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) + ;; Update buffer pointers + (data-put 1 chunk) + (let ((blen (lround (index+ 16 (index-ash chunk 1))))) + (length-put 2 (index-ash blen -2)) + (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs16 - (values (if (index= chunk length) nil new-start) - (or translated-width width)))))) + (values (if (index= chunk length) nil new-start) + (or translated-width width)))))) ;;----------------------------------------------------------------------------- @@ -953,7 +953,7 @@ (declare (type display display)) (declare (clx-values min max)) (values (display-min-keycode display) - (display-max-keycode display))) + (display-max-keycode display))) ;; Should this signal device-busy like the pointer-mapping setf, and return a ;; generalized-boolean instead (true for success)? Alternatively, should the @@ -963,19 +963,19 @@ (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) ;; Setf ought to allow multiple values. (declare (type display display) - (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) + (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) (declare (clx-values (member :success :busy :failed))) (let* ((keycodes-per-modifier (index-max (length shift) - (length lock) - (length control) - (length mod1) - (length mod2) - (length mod3) - (length mod4) - (length mod5))) - (data (make-array (index* 8 keycodes-per-modifier) - :element-type 'card8 - :initial-element 0))) + (length lock) + (length control) + (length mod1) + (length mod2) + (length mod3) + (length mod4) + (length mod5))) + (data (make-array (index* 8 keycodes-per-modifier) + :element-type 'card8 + :initial-element 0))) (replace data shift) (replace data lock :start1 keycodes-per-modifier) (replace data control :start1 (index* 2 keycodes-per-modifier)) @@ -985,8 +985,8 @@ (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) - ((data keycodes-per-modifier) - ((sequence :format card8) data)) + ((data keycodes-per-modifier) + ((sequence :format card8) data)) (values (member8-get 1 :success :busy :failed))))) (defun modifier-mapping (display) @@ -995,18 +995,18 @@ (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) (let ((lists nil)) (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) - () + () (do* ((keycodes-per-modifier (card8-get 1)) - (advance-by +replysize+ keycodes-per-modifier) - (keys nil nil) - (i 0 (index+ i 1))) - ((index= i 8)) - (advance-buffer-offset advance-by) - (dotimes (j keycodes-per-modifier) - (let ((key (read-card8 j))) - (unless (zerop key) - (push key keys)))) - (push (nreverse keys) lists))) + (advance-by +replysize+ keycodes-per-modifier) + (keys nil nil) + (i 0 (index+ i 1))) + ((index= i 8)) + (advance-buffer-offset advance-by) + (dotimes (j keycodes-per-modifier) + (let ((key (read-card8 j))) + (unless (zerop key) + (push key keys)))) + (push (nreverse keys) lists))) (values-list (nreverse lists)))) ;; Either we will want lots of defconstants for well-known values, or perhaps @@ -1017,37 +1017,37 @@ ;; start/end give subrange of keysyms ;; first-keycode is the first-keycode to store at (declare (type display display) - (type array-index start) - (type card8 first-keycode) - (type (or null array-index) end) - (type (array * (* *)) keysyms)) + (type array-index start) + (type card8 first-keycode) + (type (or null array-index) end) + (type (array * (* *)) keysyms)) (let* ((keycode-end (or end (array-dimension keysyms 0))) - (keysyms-per-keycode (array-dimension keysyms 1)) - (length (index- keycode-end start)) - (size (index* length keysyms-per-keycode)) - (request-length (index+ size 2))) + (keysyms-per-keycode (array-dimension keysyms 1)) + (length (index- keycode-end start)) + (size (index* length keysyms-per-keycode)) + (request-length (index+ size 2))) (declare (type array-index keycode-end keysyms-per-keycode length request-length)) (with-buffer-request (display +x-setkeyboardmapping+ - :length (index-ash request-length 2) - :sizes (32)) + :length (index-ash request-length 2) + :sizes (32)) (data length) (length request-length) (card8 first-keycode keysyms-per-keycode) (progn - (do ((limit (index-ash (buffer-size display) -2)) - (w (index+ 2 (index-ash buffer-boffset -2))) - (i start (index+ i 1))) - ((index>= i keycode-end) - (setf (buffer-boffset display) (index-ash w 2))) - (declare (type array-index limit w i)) - (when (index> w limit) - (buffer-flush display) - (setq w (index-ash (buffer-boffset display) -2))) - (do ((j 0 (index+ j 1))) - ((index>= j keysyms-per-keycode)) - (declare (type array-index j)) - (card29-put (index* w 4) (aref keysyms i j)) - (index-incf w))))))) + (do ((limit (index-ash (buffer-size display) -2)) + (w (index+ 2 (index-ash buffer-boffset -2))) + (i start (index+ i 1))) + ((index>= i keycode-end) + (setf (buffer-boffset display) (index-ash w 2))) + (declare (type array-index limit w i)) + (when (index> w limit) + (buffer-flush display) + (setq w (index-ash (buffer-boffset display) -2))) + (do ((j 0 (index+ j 1))) + ((index>= j keysyms-per-keycode)) + (declare (type array-index j)) + (card29-put (index* w 4) (aref keysyms i j)) + (index-incf w))))))) (defun keyboard-mapping (display &key first-keycode start end data) ;; First-keycode specifies which keycode to start at (defaults to min-keycode). @@ -1055,9 +1055,9 @@ ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). ;; If DATA is specified, the results are put there. (declare (type display display) - (type (or null card8) first-keycode) - (type (or null array-index) start end) - (type (or null (array * (* *))) data)) + (type (or null card8) first-keycode) + (type (or null array-index) start end) + (type (or null (array * (* *))) data)) (declare (clx-values (array * (* *)))) (unless first-keycode (setq first-keycode (display-min-keycode display))) (unless start (setq start first-keycode)) @@ -1065,20 +1065,20 @@ (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) ((card8 first-keycode (index- end start))) (do* ((keysyms-per-keycode (card8-get 1)) - (bytes-per-keycode (* keysyms-per-keycode 4)) - (advance-by +replysize+ bytes-per-keycode) - (keycode-count (floor (card32-get 4) keysyms-per-keycode) - (index- keycode-count 1)) - (result (if (and (arrayp data) - (= (array-rank data) 2) - (>= (array-dimension data 0) (index+ start keycode-count)) - (>= (array-dimension data 1) keysyms-per-keycode)) - data - (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) - :element-type 'keysym :initial-element 0))) - (i start (1+ i))) - ((zerop keycode-count) (setq data result)) + (bytes-per-keycode (* keysyms-per-keycode 4)) + (advance-by +replysize+ bytes-per-keycode) + (keycode-count (floor (card32-get 4) keysyms-per-keycode) + (index- keycode-count 1)) + (result (if (and (arrayp data) + (= (array-rank data) 2) + (>= (array-dimension data 0) (index+ start keycode-count)) + (>= (array-dimension data 1) keysyms-per-keycode)) + data + (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) + :element-type 'keysym :initial-element 0))) + (i start (1+ i))) + ((zerop keycode-count) (setq data result)) (advance-buffer-offset advance-by) (dotimes (j keysyms-per-keycode) - (setf (aref result i j) (card29-get (* j 4)))))) + (setf (aref result i j) (card29-get (* j 4)))))) data) diff --git a/src/clx/translate.lisp b/src/clx/translate.lisp index dc3083fdf..aca0c3a20 100644 --- a/src/clx/translate.lisp +++ b/src/clx/translate.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- ;;; -;;; TEXAS INSTRUMENTS INCORPORATED -;;; P.O. BOX 2909 -;;; AUSTIN, TEXAS 78769 +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; @@ -25,28 +25,28 @@ ;; last-keysym to be in SET (returned from the keysym-set function). ;; Signals an error if the keysym range overlaps an existing set. (declare (type keyword set) - (type keysym first-keysym last-keysym)) + (type keysym first-keysym last-keysym)) (when (> first-keysym last-keysym) (rotatef first-keysym last-keysym)) (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) (dolist (set *keysym-sets*) (let ((first (second set)) - (last (third set))) + (last (third set))) (when (or (<= first first-keysym last) - (<= first last-keysym last)) - (error "Keysym range overlaps existing set ~s" set)))) + (<= first last-keysym last)) + (error "Keysym range overlaps existing set ~s" set)))) (push (list set first-keysym last-keysym) *keysym-sets*) set) (defun keysym-set (keysym) ;; Return the character code set name of keysym (declare (type keysym keysym) - (clx-values keyword)) + (clx-values keyword)) (dolist (set *keysym-sets*) (let ((first (second set)) - (last (third set))) + (last (third set))) (when (<= first keysym last) - (return (first set)))))) + (return (first set)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro keysym (keysym &rest bytes) @@ -64,17 +64,17 @@ ;; FIXME: The above means that this shouldn't really be a macro at ;; all, but a compiler macro. Probably, anyway. (declare (type t keysym) - (type list bytes) - (clx-values keysym)) + (type list bytes) + (clx-values keysym)) (typecase keysym ((integer 0 *) (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) (otherwise (or (car (character->keysyms keysym)) - (error "~s Isn't the name of a keysym" keysym)))))) + (error "~s Isn't the name of a keysym" keysym)))))) (defvar *keysym->character-map* - (make-hash-table :test (keysym->character-map-test) :size 400)) + (make-hash-table :test (keysym->character-map-test) :size 400)) ;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) ;; With the following accessor macros. Everything after OBJECT is optional. @@ -106,11 +106,11 @@ `(fifth ,keysym-mapping)) (defvar *default-keysym-translate-mask* - (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - (logand #xff (lognot (make-state-mask :lock)))) + (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) + (logand #xff (lognot (make-state-mask :lock)))) "Default keysym state mask to use during keysym-translation.") -(defun define-keysym (object keysym &key lowercase translate modifiers mask display) +(defun define-keysym (object keysym &key lowercase translate modifiers mask display) ;; Define the translation from keysym/modifiers to a (usually ;; character) object. ANy previous keysym definition with ;; KEYSYM and MODIFIERS is deleted before adding the new definition. @@ -142,75 +142,75 @@ ;; The default is #'default-keysym-translate ;; (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) - mask) - (type (or null display) display) + (type keysym keysym) + (type (or null mask16 (clx-list (or keysym state-mask-key))) + modifiers) + (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) + mask) + (type (or null display) display) (type (or null keysym) lowercase) - (type (or null (function (display card16 t) t)) translate)) + (type (or null (function (display card16 t) t)) translate)) (flet ((merge-keysym-mappings (new old) - ;; Merge new keysym-mapping with list of old mappings. - ;; Ensure that the mapping with no modifiers or mask comes first. - (let* ((key (keysym-mapping-modifiers new)) - (merge (delete key old :key #'cadddr :test #'equal))) - (if key - (nconc merge (list new)) - (cons new merge)))) - (mask-check (mask) - (unless (or (numberp mask) - (dolist (element mask t) - (unless (or (find element +state-mask-vector+) - (gethash element *keysym->character-map*)) - (return nil)))) - (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) + ;; Merge new keysym-mapping with list of old mappings. + ;; Ensure that the mapping with no modifiers or mask comes first. + (let* ((key (keysym-mapping-modifiers new)) + (merge (delete key old :key #'cadddr :test #'equal))) + (if key + (nconc merge (list new)) + (cons new merge)))) + (mask-check (mask) + (unless (or (numberp mask) + (dolist (element mask t) + (unless (or (find element +state-mask-vector+) + (gethash element *keysym->character-map*)) + (return nil)))) + (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) (let ((entry - ;; Create with a single LIST call, to ensure cdr-coding - (cond - (mask - (unless (eq mask :modifiers) - (mask-check mask)) - (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) - (error "Mask with no modifiers")) - (list object translate lowercase modifiers mask)) - (modifiers (mask-check modifiers) - (list object translate lowercase modifiers)) - (lowercase (list object translate lowercase)) - (translate (list object translate)) - (t (list object))))) + ;; Create with a single LIST call, to ensure cdr-coding + (cond + (mask + (unless (eq mask :modifiers) + (mask-check mask)) + (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) + (error "Mask with no modifiers")) + (list object translate lowercase modifiers mask)) + (modifiers (mask-check modifiers) + (list object translate lowercase modifiers)) + (lowercase (list object translate lowercase)) + (translate (list object translate)) + (t (list object))))) (if display - (let ((previous (assoc keysym (display-keysym-translation display)))) - (if previous - (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) - (push (list keysym entry) (display-keysym-translation display)))) - (setf (gethash keysym *keysym->character-map*) - (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) + (let ((previous (assoc keysym (display-keysym-translation display)))) + (if previous + (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) + (push (list keysym entry) (display-keysym-translation display)))) + (setf (gethash keysym *keysym->character-map*) + (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) object)) -(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) +(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. (declare (type (or base-char t) object) - (type keysym keysym) - (type (or null mask16 (clx-list (or keysym state-mask-key))) - modifiers) - (type (or null display) display)) + (type keysym keysym) + (type (or null mask16 (clx-list (or keysym state-mask-key))) + modifiers) + (type (or null display) display)) (flet ((match (key entry) - (let ((object (car key)) - (modifiers (cdr key))) - (or (eql object (keysym-mapping-object entry)) - (equal modifiers (keysym-mapping-modifiers entry)))))) + (let ((object (car key)) + (modifiers (cdr key))) + (or (eql object (keysym-mapping-object entry)) + (equal modifiers (keysym-mapping-modifiers entry)))))) (let* (entry - (previous (if display - (cdr (setq entry (assoc keysym (display-keysym-translation display)))) - (gethash keysym *keysym->character-map*))) - (key (cons object modifiers))) + (previous (if display + (cdr (setq entry (assoc keysym (display-keysym-translation display)))) + (gethash keysym *keysym->character-map*))) + (key (cons object modifiers))) (when (and previous (find key previous :test #'match)) - (setq previous (delete key previous :test #'match)) - (if display - (setf (cdr entry) previous) - (setf (gethash keysym *keysym->character-map*) previous)))))) + (setq previous (delete key previous :test #'match)) + (if display + (setf (cdr entry) previous) + (setf (gethash keysym *keysym->character-map*) previous)))))) (defun keysym-downcase (keysym) ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. @@ -226,7 +226,7 @@ (declare (clx-values (or null keysym))) (let ((translations (gethash keysym *keysym->character-map*))) (and translations - (keysym-mapping-lowercase (first translations))))) + (keysym-mapping-lowercase (first translations))))) (defun character->keysyms (character &optional display) ;; Given a character, return a list of all matching keysyms. @@ -235,18 +235,18 @@ ;; Implementation dependent function. ;; May be slow [i.e. do a linear search over all known keysyms] (declare (type t character) - (type (or null display) display) - (clx-values (clx-list keysym))) + (type (or null display) display) + (clx-values (clx-list keysym))) (let ((result nil)) (when display (dolist (mapping (display-keysym-translation display)) - (when (eql character (second mapping)) - (push (first mapping) result)))) + (when (eql character (second mapping)) + (push (first mapping) result)))) (maphash #'(lambda (keysym mappings) - (dolist (mapping mappings) - (when (eql (keysym-mapping-object mapping) character) - (pushnew keysym result)))) - *keysym->character-map*) + (dolist (mapping mappings) + (when (eql (keysym-mapping-object mapping) character) + (pushnew keysym result)))) + *keysym->character-map*) result)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -278,86 +278,86 @@ (defun keycode->keysym (display keycode keysym-index) (declare (type display display) - (type card8 keycode) - (type card8 keysym-index) - (clx-values keysym)) + (type card8 keycode) + (type card8 keysym-index) + (clx-values keysym)) (let* ((mapping (display-keyboard-mapping display)) - (keysym (aref mapping keycode keysym-index))) + (keysym (aref mapping keycode keysym-index))) (declare (type (simple-array keysym (* *)) mapping) - (type keysym keysym)) + (type keysym keysym)) ;; The keysym-mapping is brain dammaged. ;; Mappings for both-case alphabetic characters have the ;; entry for keysym-index zero set to the uppercase keysym ;; (this is normally where the lowercase keysym goes), and the ;; entry for keysym-index one is zero. - (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms - (keysym-downcase keysym)) - ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym - (aref mapping keycode 0)) - (t keysym)))) + (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms + (keysym-downcase keysym)) + ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym + (aref mapping keycode 0)) + (t keysym)))) (defun keysym->character (display keysym &optional (state 0)) ;; Find the character associated with a keysym. ;; STATE can be used to set character attributes. ;; Implementation dependent function. (declare (type display display) - (type keysym keysym) - (type card16 state)) + (type keysym keysym) + (type card16 state)) (declare (clx-values (or null character))) (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) - (mapping (or ;; Find the matching display mapping - (dolist (mapping display-mappings) - (when (mapping-matches-p display state mapping) - (return mapping))) - ;; Find the matching static mapping - (dolist (mapping (gethash keysym *keysym->character-map*)) - (when (mapping-matches-p display state mapping) - (return mapping)))))) + (mapping (or ;; Find the matching display mapping + (dolist (mapping display-mappings) + (when (mapping-matches-p display state mapping) + (return mapping))) + ;; Find the matching static mapping + (dolist (mapping (gethash keysym *keysym->character-map*)) + (when (mapping-matches-p display state mapping) + (return mapping)))))) (when mapping (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) - display state (keysym-mapping-object mapping))))) + display state (keysym-mapping-object mapping))))) (defun mapping-matches-p (display state mapping) ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY (declare (type display display) - (type mask16 state) - (type list mapping)) + (type mask16 state) + (type list mapping)) (declare (clx-values generalized-boolean)) (flet ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, ;; otherwise ignore unknown modifiers. - (declare (type list display-mapping) ; Alist of (keysym . mask) - (type (or mask16 list) modifiers) - (type mask16 mask)) + (declare (type list display-mapping) ; Alist of (keysym . mask) + (type (or mask16 list) modifiers) + (type mask16 mask)) (declare (clx-values (or null mask16))) (if (numberp modifiers) - modifiers - (dolist (modifier modifiers mask) - (declare (type symbol modifier)) - (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) - (setq mask - (logior mask - (if bit - (ash 1 bit) - (or (cdr (assoc modifier display-mapping)) - ;; bad modifier - (if errorp - (return-from modifiers->mask nil) - 0)))))))))) + modifiers + (dolist (modifier modifiers mask) + (declare (type symbol modifier)) + (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) + (setq mask + (logior mask + (if bit + (ash 1 bit) + (or (cdr (assoc modifier display-mapping)) + ;; bad modifier + (if errorp + (return-from modifiers->mask nil) + 0)))))))))) (let* ((display-mapping (get-display-modifier-mapping display)) - (mapping-modifiers (keysym-mapping-modifiers mapping)) - (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) - (return-from mapping-matches-p nil))) - (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. - (if mapping-modifiers ; If no modifiers, match anything. - *default-keysym-translate-mask* - 0))) - (mask (if (eq mapping-mask :modifiers) - modifiers - (modifiers->mask display-mapping mapping-mask nil)))) + (mapping-modifiers (keysym-mapping-modifiers mapping)) + (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) + (return-from mapping-matches-p nil))) + (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. + (if mapping-modifiers ; If no modifiers, match anything. + *default-keysym-translate-mask* + 0))) + (mask (if (eq mapping-mask :modifiers) + modifiers + (modifiers->mask display-mapping mapping-mask nil)))) (declare (type mask16 modifiers mask)) (= (logand state mask) modifiers)))) @@ -365,50 +365,50 @@ ;; Returns a keysym-index for use with keycode->character (declare (clx-values card8)) (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) + `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((mapping (display-keyboard-mapping display)) - (keysyms-per-keycode (array-dimension mapping 1)) - (symbolp (and (> keysyms-per-keycode 2) - (state-keysymp display state character-set-switch-keysym))) - (result (if symbolp 2 0))) + (keysyms-per-keycode (array-dimension mapping 1)) + (symbolp (and (> keysyms-per-keycode 2) + (state-keysymp display state character-set-switch-keysym))) + (result (if symbolp 2 0))) (declare (type (simple-array keysym (* *)) mapping) - (type generalized-boolean symbolp) - (type card8 keysyms-per-keycode result)) + (type generalized-boolean symbolp) + (type card8 keysyms-per-keycode result)) (when (and (< result keysyms-per-keycode) - (keysym-shift-p display state (keysym-uppercase-alphabetic-p - (aref mapping keycode 0)))) - (incf result)) + (keysym-shift-p display state (keysym-uppercase-alphabetic-p + (aref mapping keycode 0)))) + (incf result)) result))) (defun keysym-shift-p (display state uppercase-alphabetic-p &key - shift-lock-xors - (control-modifiers - '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) + shift-lock-xors + (control-modifiers + '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) (declare (type display display) - (type card16 state) - (type generalized-boolean uppercase-alphabetic-p) - (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same - ;;; as neither if the character is alphabetic. + (type card16 state) + (type generalized-boolean uppercase-alphabetic-p) + (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same + ;;; as neither if the character is alphabetic. (declare (clx-values generalized-boolean)) (macrolet ((keystate-p (state keyword) - `(logbitp ,(position keyword +state-mask-vector+) ,state))) + `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((controlp (or (keystate-p state :control) - (dolist (modifier control-modifiers) - (when (state-keysymp display state modifier) - (return t))))) - (shiftp (keystate-p state :shift)) - (lockp (keystate-p state :lock)) - (alphap (or uppercase-alphabetic-p - (not (state-keysymp display #.(make-state-mask :lock) - caps-lock-keysym))))) + (dolist (modifier control-modifiers) + (when (state-keysymp display state modifier) + (return t))))) + (shiftp (keystate-p state :shift)) + (lockp (keystate-p state :lock)) + (alphap (or uppercase-alphabetic-p + (not (state-keysymp display #.(make-state-mask :lock) + caps-lock-keysym))))) (declare (type generalized-boolean controlp shiftp lockp alphap)) ;; Control keys aren't affected by lock (unless controlp - ;; Not a control character - check state of lock modifier - (when (and lockp - alphap - (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors - (setq shiftp (not shiftp)))) + ;; Not a control character - check state of lock modifier + (when (and lockp + alphap + (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors + (setq shiftp (not shiftp)))) shiftp))) ;;; default-keysym-index implements the following tables: @@ -434,7 +434,7 @@ ;;; 1 1 1 #\control-shift-a #\control-8 (defun keycode->character (display keycode state &key keysym-index - (keysym-index-function #'default-keysym-index)) + (keysym-index-function #'default-keysym-index)) ;; keysym-index defaults to the result of keysym-index-function which ;; is called with the following parameters: ;; (char0 state caps-lock-p keysyms-per-keycode) @@ -444,54 +444,54 @@ ;; STATE can also used for setting character attributes. ;; Implementation dependent function. (declare (type display display) - (type card8 keycode) - (type card16 state) - (type (or null card8) keysym-index) - (type (or null (function (base-char card16 generalized-boolean card8) card8)) - keysym-index-function)) + (type card8 keycode) + (type card16 state) + (type (or null card8) keysym-index) + (type (or null (function (base-char card16 generalized-boolean card8) card8)) + keysym-index-function)) (declare (clx-values (or null character))) (let* ((index (or keysym-index - (funcall keysym-index-function display keycode state))) - (keysym (if index (keycode->keysym display keycode index) 0))) + (funcall keysym-index-function display keycode state))) + (keysym (if index (keycode->keysym display keycode index) 0))) (declare (type (or null card8) index) - (type keysym keysym)) + (type keysym keysym)) (when (plusp keysym) (keysym->character display keysym state)))) (defun get-display-modifier-mapping (display) (labels ((keysym-replace (display modifiers mask &aux result) - (dolist (modifier modifiers result) - (push (cons (keycode->keysym display modifier 0) mask) result)))) + (dolist (modifier modifiers result) + (push (cons (keycode->keysym display modifier 0) mask) result)))) (or (display-modifier-mapping display) - (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) - (modifier-mapping display) - (setf (display-modifier-mapping display) - (nconc (keysym-replace display shift #.(make-state-mask :shift)) - (keysym-replace display lock #.(make-state-mask :lock)) - (keysym-replace display control #.(make-state-mask :control)) - (keysym-replace display mod1 #.(make-state-mask :mod-1)) - (keysym-replace display mod2 #.(make-state-mask :mod-2)) - (keysym-replace display mod3 #.(make-state-mask :mod-3)) - (keysym-replace display mod4 #.(make-state-mask :mod-4)) - (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) + (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) + (modifier-mapping display) + (setf (display-modifier-mapping display) + (nconc (keysym-replace display shift #.(make-state-mask :shift)) + (keysym-replace display lock #.(make-state-mask :lock)) + (keysym-replace display control #.(make-state-mask :control)) + (keysym-replace display mod1 #.(make-state-mask :mod-1)) + (keysym-replace display mod2 #.(make-state-mask :mod-2)) + (keysym-replace display mod3 #.(make-state-mask :mod-3)) + (keysym-replace display mod4 #.(make-state-mask :mod-4)) + (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) (defun state-keysymp (display state keysym) ;; Returns T when a modifier key associated with KEYSYM is on in STATE (declare (type display display) - (type card16 state) - (type keysym keysym)) + (type card16 state) + (type keysym keysym)) (declare (clx-values generalized-boolean)) (let* ((mapping (get-display-modifier-mapping display)) - (mask (assoc keysym mapping))) + (mask (assoc keysym mapping))) (and mask (plusp (logand state (cdr mask)))))) (defun mapping-notify (display request start count) ;; Called on a mapping-notify event to update ;; the keyboard-mapping cache in DISPLAY (declare (type display display) - (type (member :modifier :keyboard :pointer) request) - (type card8 start count) - (ignore count start)) + (type (member :modifier :keyboard :pointer) request) + (type card8 start count) + (ignore count start)) ;; Invalidate the keyboard mapping to force the next key translation to get it (case request (:modifier @@ -502,61 +502,61 @@ (defun keysym-in-map-p (display keysym keymap) ;; Returns T if keysym is found in keymap (declare (type display display) - (type keysym keysym) - (type (bit-vector 256) keymap)) + (type keysym keysym) + (type (bit-vector 256) keymap)) (declare (clx-values generalized-boolean)) ;; The keysym may appear in the keymap more than once, ;; So we have to search the entire keysym map. (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i))) + (max (display-max-keycode display)) + (map (display-keyboard-mapping display)) + (jmax (min 2 (array-dimension map 1))) + (i min (1+ i))) ((> i max)) (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) + (type (simple-array keysym (* *)) map)) (when (and (plusp (aref keymap i)) - (dotimes (j jmax) - (when (= keysym (aref map i j)) (return t)))) + (dotimes (j jmax) + (when (= keysym (aref map i j)) (return t)))) (return t)))) (defun character-in-map-p (display character keymap) ;; Implementation dependent function. ;; Returns T if character is found in keymap (declare (type display display) - (type character character) - (type (bit-vector 256) keymap)) + (type character character) + (type (bit-vector 256) keymap)) (declare (clx-values generalized-boolean)) ;; Check all one bits in keymap (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (jmax (array-dimension (display-keyboard-mapping display) 1)) - (i min (1+ i))) + (max (display-max-keycode display)) + (jmax (array-dimension (display-keyboard-mapping display) 1)) + (i min (1+ i))) ((> i max)) (declare (type card8 min max jmax)) (when (and (plusp (aref keymap i)) - ;; Match when character is in mapping for this keycode - (dotimes (j jmax) - (when (eql character (keycode->character display i 0 :keysym-index j)) - (return t)))) + ;; Match when character is in mapping for this keycode + (dotimes (j jmax) + (when (eql character (keycode->character display i 0 :keysym-index j)) + (return t)))) (return t)))) (defun keysym->keycodes (display keysym) ;; Return keycodes for keysym, as multiple values (declare (type display display) - (type keysym keysym)) + (type keysym keysym)) (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) ;; The keysym may appear in the keymap more than once, ;; So we have to search the entire keysym map. (do* ((min (display-min-keycode display)) - (max (display-max-keycode display)) - (map (display-keyboard-mapping display)) - (jmax (min 2 (array-dimension map 1))) - (i min (1+ i)) - (result nil)) + (max (display-max-keycode display)) + (map (display-keyboard-mapping display)) + (jmax (min 2 (array-dimension map 1))) + (i min (1+ i)) + (result nil)) ((> i max) (values-list result)) (declare (type card8 min max jmax) - (type (simple-array keysym (* *)) map)) + (type (simple-array keysym (* *)) map)) (dotimes (j jmax) (when (= keysym (aref map i j)) - (push i result))))) + (push i result))))) diff --git a/src/clx/xinerama.lisp b/src/clx/xinerama.lisp index ee688e64b..8aeca38e0 100644 --- a/src/clx/xinerama.lisp +++ b/src/clx/xinerama.lisp @@ -16,14 +16,14 @@ (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" - "WITH-BUFFER-REQUEST" - "WITH-BUFFER-REQUEST-AND-REPLY" - "DATA" - "BOOLEAN" "BOOLEAN-GET" - "CARD8" "CARD8-GET" - "CARD16" "CARD16-GET" - "CARD32" "CARD32-GET" - "INT16" "INT16-GET") + "WITH-BUFFER-REQUEST" + "WITH-BUFFER-REQUEST-AND-REPLY" + "DATA" + "BOOLEAN" "BOOLEAN-GET" + "CARD8" "CARD8-GET" + "CARD16" "CARD16-GET" + "CARD32" "CARD32-GET" + "INT16" "INT16-GET") (:export "SCREEN-INFO" "SCREEN-INFO-NUMBER" "SCREEN-INFO-X" diff --git a/src/clx/xrender.lisp b/src/clx/xrender.lisp index bb605dadc..56f412533 100644 --- a/src/clx/xrender.lisp +++ b/src/clx/xrender.lisp @@ -83,26 +83,26 @@ ;; Beginning to collect the external interface for documentation. (export '(render-create-picture - render-free-picture - - render-create-glyph-set - render-reference-glyph-set - render-free-glyph-set - - render-add-glyph - render-add-glyph-from-picture - render-free-glyph + render-free-picture + + render-create-glyph-set + render-reference-glyph-set + render-free-glyph-set + + render-add-glyph + render-add-glyph-from-picture + render-free-glyph render-fill-rectangle - picture-format-display - picture-format-id - picture-format-type - picture-format-depth - picture-format-red-byte - picture-format-green-byte - picture-format-blue-byte - picture-format-alpha-byte - picture-format-colormap + picture-format-display + picture-format-id + picture-format-type + picture-format-depth + picture-format-red-byte + picture-format-green-byte + picture-format-blue-byte + picture-format-alpha-byte + picture-format-colormap ;; picture object picture-repeat @@ -817,56 +817,56 @@ by every function, which attempts to generate RENDER requests." (opcode type transform display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end) (let ((size (ecase type (card8 1) (card16 2) (card32 4))) - ;; FIXME: the last chunk for CARD8 can be 254. - (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) + ;; FIXME: the last chunk for CARD8 can be 254. + (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) `(multiple-value-bind (nchunks leftover) (floor (- end start) ,chunksize) (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) - (if (> leftover 0) - (+ 8 (* 4 (ceiling (* leftover ,size) 4))) - 0))) - (request-length (+ 7 (/ payloadsize 4)))) - (declare (integer request-length)) - (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) - (data ,opcode) - (length request-length) - (render-op ,alu) - (card8 0) (card16 0) ;padding - (picture ,source) - (picture ,dest) - ((or (member :none) picture-format) ,mask-format) - (glyph-set ,glyph-set) - (int16 ,src-x) (int16 ,src-y) - (progn - (let ((boffset (+ buffer-boffset 28)) - (start ,start) - (end ,end) - (dest-x ,dest-x) - (dest-y ,dest-y)) - (dotimes (i nchunks) - (set-buffer-offset boffset) - (put-items (0) - (card8 ,chunksize) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) - (setq dest-x 0 dest-y 0) - (incf boffset (+ 8 (* ,chunksize ,size))) - (incf start ,chunksize)) - (when (> leftover 0) - (set-buffer-offset boffset) - (put-items (0) - (card8 leftover) - (card8 0) - (card16 0) - (int16 dest-x) - (int16 dest-y) - ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) - ;; padding? - (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) - (setf (buffer-boffset ,display) boffset)))))))) + (if (> leftover 0) + (+ 8 (* 4 (ceiling (* leftover ,size) 4))) + 0))) + (request-length (+ 7 (/ payloadsize 4)))) + (declare (integer request-length)) + (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) + (data ,opcode) + (length request-length) + (render-op ,alu) + (card8 0) (card16 0) ;padding + (picture ,source) + (picture ,dest) + ((or (member :none) picture-format) ,mask-format) + (glyph-set ,glyph-set) + (int16 ,src-x) (int16 ,src-y) + (progn + (let ((boffset (+ buffer-boffset 28)) + (start ,start) + (end ,end) + (dest-x ,dest-x) + (dest-y ,dest-y)) + (dotimes (i nchunks) + (set-buffer-offset boffset) + (put-items (0) + (card8 ,chunksize) + (card8 0) + (card16 0) + (int16 dest-x) + (int16 dest-y) + ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) + (setq dest-x 0 dest-y 0) + (incf boffset (+ 8 (* ,chunksize ,size))) + (incf start ,chunksize)) + (when (> leftover 0) + (set-buffer-offset boffset) + (put-items (0) + (card8 leftover) + (card8 0) + (card16 0) + (int16 dest-x) + (int16 dest-y) + ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) + ;; padding? + (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) + (setf (buffer-boffset ,display) boffset)))))))) (defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence &key (op :over) @@ -931,10 +931,10 @@ by every function, which attempts to generate RENDER requests." (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) + (* w (picture-format-depth (glyph-set-format glyph-set))) + 32))) (request-length (+ 28 - (* h byte-per-line)))) + (* h byte-per-line)))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) (length (ceiling request-length 4)) diff --git a/src/clx/xvidmode.lisp b/src/clx/xvidmode.lisp index 827cd4af0..8fd940947 100644 --- a/src/clx/xvidmode.lisp +++ b/src/clx/xvidmode.lisp @@ -38,45 +38,45 @@ (in-package :xlib) (export '(mode-info - mode-info-dotclock - mode-info-hdisplay - mode-info-hsyncstart - mode-info-hsyncend - mode-info-htotal - mode-info-hskew - mode-info-vdisplay - mode-info-vsyncstart - mode-info-vsyncend - mode-info-vtotal - mode-info-flags - mode-info-privsize - mode-info-private - make-mode-info + mode-info-dotclock + mode-info-hdisplay + mode-info-hsyncstart + mode-info-hsyncend + mode-info-htotal + mode-info-hskew + mode-info-vdisplay + mode-info-vsyncstart + mode-info-vsyncend + mode-info-vtotal + mode-info-flags + mode-info-privsize + mode-info-private + make-mode-info - xfree86-vidmode-query-version - xfree86-vidmode-set-client-version - xfree86-vidmode-get-permissions - xfree86-vidmode-mod-mode-line - xfree86-vidmode-get-mode-line - xfree86-vidmode-get-all-mode-lines - xfree86-vidmode-add-mode-line - xfree86-vidmode-delete-mode-line - xfree86-vidmode-validate-mode-line - xfree86-vidmode-get-gamma - xfree86-vidmode-set-gamma - xfree86-vidmode-get-gamma-ramp - xfree86-vidmode-set-gamma-ramp - xfree86-vidmode-get-gamma-ramp-size - xfree86-vidmode-lock-mode-switch - xfree86-vidmode-switch-to-mode - xfree86-vidmode-switch-mode - xfree86-vidmode-select-next-mode - xfree86-vidmode-select-prev-mode - xfree86-vidmode-get-monitor - xfree86-vidmode-get-viewport - xfree86-vidmode-set-viewport - xfree86-vidmode-get-dotclocks) - :xlib) + xfree86-vidmode-query-version + xfree86-vidmode-set-client-version + xfree86-vidmode-get-permissions + xfree86-vidmode-mod-mode-line + xfree86-vidmode-get-mode-line + xfree86-vidmode-get-all-mode-lines + xfree86-vidmode-add-mode-line + xfree86-vidmode-delete-mode-line + xfree86-vidmode-validate-mode-line + xfree86-vidmode-get-gamma + xfree86-vidmode-set-gamma + xfree86-vidmode-get-gamma-ramp + xfree86-vidmode-set-gamma-ramp + xfree86-vidmode-get-gamma-ramp-size + xfree86-vidmode-lock-mode-switch + xfree86-vidmode-switch-to-mode + xfree86-vidmode-switch-mode + xfree86-vidmode-select-next-mode + xfree86-vidmode-select-prev-mode + xfree86-vidmode-get-monitor + xfree86-vidmode-get-viewport + xfree86-vidmode-set-viewport + xfree86-vidmode-get-dotclocks) + :xlib) ;; current version numbers ;; @@ -114,12 +114,12 @@ (define-extension "XFree86-VidModeExtension" :events (:xfree86-vidmode-notify) :errors (xf86-vidmode-bad-clock - xf86-vidmode-bad-htimings - xf86-vidmode-bad-vtimings - xf86-vidmode-mode-unsuitable - xf86-vidmode-extension-disabled - xf86-vidmode-client-not-local - xf86-vidmode-zoom-locked)) + xf86-vidmode-bad-htimings + xf86-vidmode-bad-vtimings + xf86-vidmode-mode-unsuitable + xf86-vidmode-extension-disabled + xf86-vidmode-client-not-local + xf86-vidmode-zoom-locked)) (define-condition xf86-vidmode-bad-clock (request-error) ()) (define-condition xf86-vidmode-bad-htimings (request-error) ()) @@ -166,12 +166,12 @@ (declaim (inline screen-position)) (defun screen-position (screen display) (declare (type display display) - (type screen screen)) + (type screen screen)) (declare (clx-values position)) (let ((position (position screen (xlib:display-roots display)))) (if (not (numberp position)) - (error "screen ~A not found in display ~A" screen display) - position))) + (error "screen ~A not found in display ~A" screen display) + position))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; @@ -187,7 +187,7 @@ return two values major-version and minor-version in that order." (display (vidmode-opcode display) nil :sizes 16) ((data +query-version+)) (let ((major (card16-get 8)) - (minor (card16-get 10))) + (minor (card16-get 10))) (declare (type card16 major minor)) (when (>= major 2) (XFree86-VidMode-set-client-version display)) @@ -202,7 +202,7 @@ return two values major-version and minor-version in that order." (defun xfree86-vidmode-get-permissions (dpy screen) (declare (type display dpy) - (type screen screen)) + (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-permisions+) @@ -216,11 +216,11 @@ return two values major-version and minor-version in that order." requested settings are valid (e.g. they don't exceed the capabilities of the monitor)." (declare (type display display) - (type screen screen)) + (type screen screen)) (let* ((major (xfree86-vidmode-query-version display)) - (v (mode-info->v-card16 mode-line major))) + (v (mode-info->v-card16 mode-line major))) (declare (type card16 major) - (type simple-vector v)) + (type simple-vector v)) (with-buffer-request (display (vidmode-opcode display)) (data +mod-mode-line+) (card32 (screen-position screen display)) @@ -233,44 +233,44 @@ If there are any server private values (currently only applicable to the S3 server) the function will store it into the returned structure." (declare (clx-values mode-info) - (type display display) - (type screen screen)) + (type display display) + (type screen screen)) (let ((major (xfree86-vidmode-query-version display)) - (offset 8)) + (offset 8)) (declare (type fixnum offset) - (type card16 major)) + (type card16 major)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-mode-line+) (card16 (screen-position screen display)) (card16 0)) (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card16-get (incf offset 2))) - :vdisplay (card16-get (incf offset 2)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 4))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) + (make-mode-info + :dotclock (card32-get offset) + :hdisplay (card16-get (incf offset 4)) + :hsyncstart (card16-get (incf offset 2)) + :hsyncend (card16-get (incf offset 2)) + :htotal (card16-get (incf offset 2)) + :hskew (if (< major 2) 0 (card16-get (incf offset 2))) + :vdisplay (card16-get (incf offset 2)) + :vsyncstart (card16-get (incf offset 2)) + :vsyncend (card16-get (incf offset 2)) + :vtotal (card16-get (incf offset 2)) + :flags (card32-get (incf offset (if (< major 2) 2 4))))) + (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) + (mode-info-private mode-info) + (sequence-get :format card32 :index offset + :length size :result-type 'list)) mode-info)))) (defun xfree86-vidmode-get-all-mode-lines (dpy screen) "Returns a list containing all video modes (as mode-info structure). The first element of the list corresponds to the current video mode." (declare (type display dpy) - (type screen screen)) + (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) (with-buffer-request-and-reply @@ -282,54 +282,54 @@ The first element of the list corresponds to the current video mode." ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (loop with bug-p = (and (= major 0) (< minor 8)) - with offset of-type fixnum = 32 + with offset of-type fixnum = 32 for i of-type card32 from 0 below (or (card32-get 8) 0) - collect - (let ((mode-info - (make-mode-info - :dotclock (card32-get offset) - :hdisplay (card16-get (incf offset 4)) - :hsyncstart (card16-get (incf offset 2)) - :hsyncend (card16-get (incf offset 2)) - :htotal (card16-get (incf offset 2)) - :hskew (if (< major 2) 0 (card32-get (incf offset 2))) - :vdisplay (card16-get (incf offset 4)) - :vsyncstart (card16-get (incf offset 2)) - :vsyncend (card16-get (incf offset 2)) - :vtotal (card16-get (incf offset 2)) - :flags (card32-get (incf offset (if (< major 2) 2 6))))) - (size (card32-get (incf offset (if (< major 2) 4 16))))) - (declare (type card32 size)) - (incf offset 4) - (when bug-p - (setf size 0)) - (setf (mode-info-privsize mode-info) size - (mode-info-private mode-info) - (sequence-get :format card32 :index offset - :length size :result-type 'list)) - (incf offset (* 4 size)) - mode-info)))))) + collect + (let ((mode-info + (make-mode-info + :dotclock (card32-get offset) + :hdisplay (card16-get (incf offset 4)) + :hsyncstart (card16-get (incf offset 2)) + :hsyncend (card16-get (incf offset 2)) + :htotal (card16-get (incf offset 2)) + :hskew (if (< major 2) 0 (card32-get (incf offset 2))) + :vdisplay (card16-get (incf offset 4)) + :vsyncstart (card16-get (incf offset 2)) + :vsyncend (card16-get (incf offset 2)) + :vtotal (card16-get (incf offset 2)) + :flags (card32-get (incf offset (if (< major 2) 2 6))))) + (size (card32-get (incf offset (if (< major 2) 4 16))))) + (declare (type card32 size)) + (incf offset 4) + (when bug-p + (setf size 0)) + (setf (mode-info-privsize mode-info) size + (mode-info-private mode-info) + (sequence-get :format card32 :index offset + :length size :result-type 'list)) + (incf offset (* 4 size)) + mode-info)))))) (defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) (declare (type display dpy) - (type screen scr)) + (type screen scr)) (let* ((private (mode-info-private new)) - (privsize (mode-info-privsize new)) - (major (xfree86-vidmode-query-version dpy)) - (i (if (< major 2) 14 22)) - (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) + (privsize (mode-info-privsize new)) + (major (xfree86-vidmode-query-version dpy)) + (i (if (< major 2) 14 22)) + (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) (declare (type card32 privsize) - (type fixnum i) - (type card16 major) - (type simple-vector v)) + (type fixnum i) + (type card16 major) + (type simple-vector v)) (mode-info->v-card16 new major :encode-private nil :data v) (mode-info->v-card16 after major :encode-private nil :data v :index i) (setf i (- (* 2 i) 2)) ;; strore private info (sequence card32) according clx bytes order. (loop for card of-type card32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ card) - (setf (svref v (incf i)) w1 - (svref v (incf i)) w2))) + do (multiple-value-bind (w1 w2) (__card32->card16__ card) + (setf (svref v (incf i)) w1 + (svref v (incf i)) w2))) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +add-mode-line+) @@ -343,11 +343,11 @@ structure must match, except the privsize and private fields. If the mode to be deleted is the current mode, a mode switch to the next mode will occur first. The last remaining mode can not be deleted." (declare (type display dpy) - (type screen scr)) + (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) + (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) - (type simple-vector v)) + (type simple-vector v)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +delete-mode-line+) (card32 (screen-position scr dpy)) @@ -403,11 +403,11 @@ combination of the server, card, and monitor) the function returns :mode_ok otherwise it returns a keyword indicating the reason why the mode is invalid." (declare (type display dpy) - (type screen scr)) + (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) - (v (mode-info->v-card16 mode-info major))) + (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) - (type simple-vector v)) + (type simple-vector v)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +validate-mode-line+) @@ -419,7 +419,7 @@ invalid." (defun xfree86-vidmode-get-gamma (display screen) (declare (type display display) - (type screen screen)) + (type screen screen)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-gamma+) @@ -435,8 +435,8 @@ invalid." (defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) (declare (type display dpy) - (type screen scr) - (type (single-float 0.100f0 10.000f0) red green blue)) + (type screen scr) + (type (single-float 0.100f0 10.000f0) red green blue)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma+) (card16 (screen-position scr dpy)) @@ -450,8 +450,8 @@ invalid." (defun xfree86-vidmode-get-gamma-ramp (dpy scr size) (declare (type display dpy) - (type screen scr) - (type card16 size)) + (type screen scr) + (type card16 size)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp+) (card16 (screen-position scr dpy)) @@ -460,33 +460,33 @@ invalid." (declare (type fixnum rep-size)) (unless (zerop rep-size) (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) - (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) - (declare (type fixnum off1 off2)) - (values - (sequence-get :format card16 :length (card16-get 8) - :index 32 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off1 :result-type 'list) - (sequence-get :format card16 :length (card16-get 8) - :index off2 :result-type 'list))))))) + (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) + (declare (type fixnum off1 off2)) + (values + (sequence-get :format card16 :length (card16-get 8) + :index 32 :result-type 'list) + (sequence-get :format card16 :length (card16-get 8) + :index off1 :result-type 'list) + (sequence-get :format card16 :length (card16-get 8) + :index off2 :result-type 'list))))))) (defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) (declare (type (or null simple-vector) red green blue) - (type card16 size) - (type display dpy) - (type screen scr)) + (type card16 size) + (type display dpy) + (type screen scr)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size) ((sequence :format card16) (if (zerop (mod size 2)) - (concatenate 'vector red green blue) + (concatenate 'vector red green blue) (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) (defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) (declare (type display dpy) - (type screen screen)) + (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp-size+) @@ -499,8 +499,8 @@ invalid." modes comes from a call to the mode switching functions or from one of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." (declare (type display display) - (type screen screen) - (type boolean lock-p)) + (type screen screen) + (type boolean lock-p)) (with-buffer-request (display (vidmode-opcode display)) (data +lock-mode-switch+) (card16 (screen-position screen display)) @@ -511,30 +511,30 @@ of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." an existing mode. Matching is as specified in the description of the xf86-vidmode-delete-mode-line function." (declare (type display display) - (type screen screen)) + (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (let ((bug-p (and (= major 0) (< minor 8))) - (privsize (mode-info-privsize mode-info))) + (privsize (mode-info-privsize mode-info))) (declare (type boolean bug-p)) (and bug-p (setf (mode-info-privsize mode-info) 0)) (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) - (declare (type simple-vector v)) - (and bug-p (setf (mode-info-privsize mode-info) privsize)) - (with-buffer-request (display (vidmode-opcode display)) - (data +switch-to-mode+) - (card32 (screen-position screen display)) - ((sequence :format card16) v)))))) + (declare (type simple-vector v)) + (and bug-p (setf (mode-info-privsize mode-info) privsize)) + (with-buffer-request (display (vidmode-opcode display)) + (data +switch-to-mode+) + (card32 (screen-position screen display)) + ((sequence :format card16) v)))))) (defun xfree86-vidmode-switch-mode (display screen zoom) "Change the video mode to next (or previous) video mode, depending of zoom sign. If positive, switch to next mode, else switch to prev mode." (declare (type display display) - (type screen screen) - (type card16 zoom)) + (type screen screen) + (type card16 zoom)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) @@ -543,7 +543,7 @@ of zoom sign. If positive, switch to next mode, else switch to prev mode." (defun xfree86-vidmode-select-next-mode (display screen) "Change the video mode to next video mode" (declare (type display display) - (type screen screen)) + (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) @@ -552,7 +552,7 @@ of zoom sign. If positive, switch to next mode, else switch to prev mode." (defun xfree86-vidmode-select-prev-mode (display screen) "Change the video mode to previous video mode" (declare (type display display) - (type screen screen)) + (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) @@ -569,31 +569,31 @@ Multiple value return: The hi and low values will be equal if a discreate value was given in the XF86Config file." (declare (type display dpy) - (type screen screen)) + (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-monitor+) (card16 (screen-position screen dpy)) (card16 0)) (let* ((vendor-name-length (card8-get 8)) - (model-name-length (card8-get 9)) - (pad (- 4 (mod vendor-name-length 4))) - (nhsync (card8-get 10)) - (nvsync (card8-get 11)) - (vindex (+ 32 (* 4 (+ nhsync nvsync)))) - (mindex (+ vindex vendor-name-length pad)) - (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) - (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) - :result-type 'list))) + (model-name-length (card8-get 9)) + (pad (- 4 (mod vendor-name-length 4))) + (nhsync (card8-get 10)) + (nvsync (card8-get 11)) + (vindex (+ 32 (* 4 (+ nhsync nvsync)))) + (mindex (+ vindex vendor-name-length pad)) + (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) + (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) + :result-type 'list))) (declare (type card8 nhsync nvsync vendor-name-length model-name-length) - (type fixnum pad vindex mindex)) + (type fixnum pad vindex mindex)) (values (loop for i of-type card32 in hsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) + collect (/ (ldb (byte 16 0) i) 100.) + collect (/ (ldb (byte 32 16) i) 100.)) (loop for i of-type card32 in vsync - collect (/ (ldb (byte 16 0) i) 100.) - collect (/ (ldb (byte 32 16) i) 100.)) + collect (/ (ldb (byte 16 0) i) 100.) + collect (/ (ldb (byte 32 16) i) 100.)) (string-get vendor-name-length vindex) (string-get model-name-length mindex))))) @@ -602,7 +602,7 @@ in the XF86Config file." the virtual screen. The upper left coordinates will be returned as a multiple value." (declare (type display dpy) - (type screen screen)) + (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions @@ -611,11 +611,11 @@ a multiple value." ;; versions. (when (and (= major 0) (< minor 8)) (format cl:*error-output* - "running an old version ~a ~a~%" - major minor) + "running an old version ~a ~a~%" + major minor) (return-from xfree86-vidmode-get-viewport nil)) (with-buffer-request-and-reply - (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) + (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-viewport+) (card16 (screen-position screen dpy)) (card16 0)) @@ -627,8 +627,8 @@ a multiple value." "Set upper left corner of the viewport into the virtual screen to the x and y keyword parameters value (zero will be theire default value)." (declare (type display dpy) - (type screen screen) - (type card32 x y)) + (type screen screen) + (type card32 x y)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-viewport+) (card16 (screen-position screen dpy)) @@ -642,7 +642,7 @@ x and y keyword parameters value (zero will be theire default value)." maxclocks clock list" (declare (type display dpy) - (type screen screen)) + (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-dot-clocks+) @@ -652,7 +652,7 @@ x and y keyword parameters value (zero will be theire default value)." (card32-get 8) ; flags (card32-get 16) ; max clocks (sequence-get :length (card32-get 12) :format card32 - :index 32 :result-type 'list)))) + :index 32 :result-type 'list)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; @@ -663,62 +663,62 @@ x and y keyword parameters value (zero will be theire default value)." (defun mode-info->v-card16 (mode-info major &key (encode-private t) (index 0) data) (declare (type integer index) - (type card16 major) - (type boolean encode-private) - (type (or null simple-vector) data)) + (type card16 major) + (type boolean encode-private) + (type (or null simple-vector) data)) (let ((dotclock (mode-info-dotclock mode-info)) - (hdisplay (mode-info-hdisplay mode-info)) - (hsyncstart (mode-info-hsyncstart mode-info)) - (hsyncend (mode-info-hsyncend mode-info)) - (htotal (mode-info-htotal mode-info)) - (hskew (mode-info-hskew mode-info)) - (vdisplay (mode-info-vdisplay mode-info)) - (vsyncstart (mode-info-vsyncstart mode-info)) - (vsyncend (mode-info-vsyncend mode-info)) - (vtotal (mode-info-vtotal mode-info)) - (flags (mode-info-flags mode-info)) - (privsize (mode-info-privsize mode-info)) - (private (mode-info-private mode-info))) + (hdisplay (mode-info-hdisplay mode-info)) + (hsyncstart (mode-info-hsyncstart mode-info)) + (hsyncend (mode-info-hsyncend mode-info)) + (htotal (mode-info-htotal mode-info)) + (hskew (mode-info-hskew mode-info)) + (vdisplay (mode-info-vdisplay mode-info)) + (vsyncstart (mode-info-vsyncstart mode-info)) + (vsyncend (mode-info-vsyncend mode-info)) + (vtotal (mode-info-vtotal mode-info)) + (flags (mode-info-flags mode-info)) + (privsize (mode-info-privsize mode-info)) + (private (mode-info-private mode-info))) (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) - (type card16 vdisplay vsyncstart vsyncend vtotal) - (type card32 dotclock flags privsize) - (type (or null sequence) private)) + (type card16 vdisplay vsyncstart vsyncend vtotal) + (type card32 dotclock flags privsize) + (type (or null sequence) private)) (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) - (v (or data (make-array size :initial-element 0)))) + (v (or data (make-array size :initial-element 0)))) (declare (type fixnum size) - (type simple-vector v)) + (type simple-vector v)) ;; store dotclock (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) - (setf (svref v index) w1 - (svref v (incf index)) w2)) + (setf (svref v index) w1 + (svref v (incf index)) w2)) (setf (svref v (incf index)) hdisplay - (svref v (incf index)) hsyncstart - (svref v (incf index)) hsyncend - (svref v (incf index)) htotal) + (svref v (incf index)) hsyncstart + (svref v (incf index)) hsyncend + (svref v (incf index)) htotal) (unless (< major 2) - (setf (svref v (incf index)) hskew)) + (setf (svref v (incf index)) hskew)) (setf (svref v (incf index)) vdisplay - (svref v (incf index)) vsyncstart - (svref v (incf index)) vsyncend - (svref v (incf index)) vtotal) + (svref v (incf index)) vsyncstart + (svref v (incf index)) vsyncend + (svref v (incf index)) vtotal) (unless (< major 2) - (incf index)) + (incf index)) ;; strore flags (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ flags) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) + (setf (svref v (incf index)) w1 + (svref v (incf index)) w2)) ;; strore privsize (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ privsize) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)) + (setf (svref v (incf index)) w1 + (svref v (incf index)) w2)) ;; reserverd byte32 1 2 3 (unless (< major 2) (incf index 6)) ;; strore private info (sequence card32) according clx bytes order. (when encode-private - (loop for i of-type int32 in private - do (multiple-value-bind (w1 w2) (__card32->card16__ i) - (setf (svref v (incf index)) w1 - (svref v (incf index)) w2)))) + (loop for i of-type int32 in private + do (multiple-value-bind (w1 w2) (__card32->card16__ i) + (setf (svref v (incf index)) w1 + (svref v (incf index)) w2)))) v))) (declaim (inline __card32->card16__)) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 46210cc08..01410a856 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -49,11 +49,11 @@ '*)))) (define-compiler-macro make-array (&whole form dimensions &key (element-type t) - (initial-element nil initial-element-supplied-p) - (initial-contents nil initial-contents-supplied-p) - adjustable fill-pointer - displaced-to (displaced-index-offset 0) - &environment env) + (initial-element nil initial-element-supplied-p) + (initial-contents nil initial-contents-supplied-p) + adjustable fill-pointer + displaced-to (displaced-index-offset 0) + &environment env) ;; This optimization is always done unless we provide content. There ;; is no speed, debug or space reason not to do it, unless the user ;; specifies not to inline MAKE-ARRAY, but in that case the compiler @@ -99,7 +99,7 @@ (vector ,(second args))) (declare (:read-only value vector) (optimize (safety 0))) - (optional-type-assertion vector vector) + (optional-type-assertion vector vector) (let ((index (fill-pointer vector)) (dimension (array-total-size vector))) (declare (fixnum index dimension) @@ -139,15 +139,15 @@ (define-compiler-macro si::aset (&whole form array &rest indices-and-value &environment env) (cond ((null indices-and-value) - (cmpwarn "Too few arguments to SI::ASET form~%~4I~A" - form) - form) - ((policy-open-code-aref/aset env) - (let* ((indices (butlast indices-and-value)) - (value (first (last indices-and-value)))) - (expand-aset array indices value env))) - (t - form))) + (cmpwarn "Too few arguments to SI::ASET form~%~4I~A" + form) + form) + ((policy-open-code-aref/aset env) + (let* ((indices (butlast indices-and-value)) + (value (first (last indices-and-value)))) + (expand-aset array indices value env))) + (t + form))) (defun expand-aset (array indices value env) (ext:with-unique-names (%array) @@ -159,10 +159,10 @@ (define-compiler-macro array-row-major-index (&whole form array &rest indices &environment env) (if (policy-open-code-aref/aset env) (with-clean-symbols (%array) - `(let ((%array ,array)) - (declare (:read-only %array) - (optimize (safety 0))) - ,(expand-row-major-index '%array indices env))) + `(let ((%array ,array)) + (declare (:read-only %array) + (optimize (safety 0))) + ,(expand-row-major-index '%array indices env))) form)) (defun expand-zero-dim-index-check (a env) @@ -180,10 +180,10 @@ (check-vector-in-bounds ,a ,index) ,index))) (if (policy-type-assertions env) - (with-clean-symbols (%array-index) - `(let ((%array-index ,index)) - (declare (:read-only %array-index)) - ,(expansion a '%array-index))) + (with-clean-symbols (%array-index) + `(let ((%array-index ,index)) + (declare (:read-only %array-index)) + ,(expansion a '%array-index))) index))) (defun expand-row-major-index (a indices env) @@ -195,30 +195,30 @@ (expand-vector-index-check a (first indices) env))) (let* ((expected-rank (length indices)) (check (policy-array-bounds-check env)) - (dims (loop for i from 0 - for index in indices - collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i)))) - (dim-names (mapcar #'first dims))) + (dims (loop for i from 0 + for index in indices + collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i)))) + (dim-names (mapcar #'first dims))) (with-clean-symbols (%ndx-var %output-var %dim-var) `(let* (,@dims - (%output-var 0)) + (%output-var 0)) (declare (type ext:array-index %output-var ,@dim-names) - (ignorable ,@dim-names)) + (ignorable ,@dim-names)) ,@(when (policy-type-assertions env) `((optional-type-assertion ,a array) (check-expected-rank ,a ,expected-rank))) - ,@(loop for i from 0 - for l in indices - for index in indices - for dim-var in dim-names - when (plusp i) - collect `(setf %output-var - (truly-the ext:array-index (* %output-var ,dim-var))) - collect `(let ((%ndx-var ,index)) - (declare (ext:array-index %ndx-var)) - ,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var)) - (setf %output-var - (truly-the ext:array-index (+ %output-var %ndx-var))))) + ,@(loop for i from 0 + for l in indices + for index in indices + for dim-var in dim-names + when (plusp i) + collect `(setf %output-var + (truly-the ext:array-index (* %output-var ,dim-var))) + collect `(let ((%ndx-var ,index)) + (declare (ext:array-index %ndx-var)) + ,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var)) + (setf %output-var + (truly-the ext:array-index (+ %output-var %ndx-var))))) %output-var)))) ;(trace c::expand-row-major-index c::expand-aset c::expand-aref) diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index c04a0e89e..61cfce8fe 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -27,9 +27,9 @@ (CLOSURE (let ((var-loc (var-loc var))) (unless (typep var-loc 'fixnum) - ;; first binding: assign location - (setq var-loc (next-env)) - (setf (var-loc var) var-loc)) + ;; first binding: assign location + (setq var-loc (next-env)) + (setf (var-loc var) var-loc)) (when (zerop var-loc) (wt-nl "env" *env-lvl* " = ECL_NIL;")) (wt-nl "CLV" var-loc " = env" *env-lvl* " = CONS(") (wt-coerce-loc :object loc) @@ -38,9 +38,9 @@ (LEXICAL (let ((var-loc (var-loc var))) (unless (consp var-loc) - ;; first binding: assign location - (setq var-loc (next-lex)) - (setf (var-loc var) var-loc)) + ;; first binding: assign location + (setq var-loc (next-lex)) + (setf (var-loc var) var-loc)) (wt-nl) (wt-lex var-loc) (wt " = ") (wt-coerce-loc :object loc) (wt ";")) @@ -49,47 +49,47 @@ (bds-bind loc var)) (t (cond ((not (eq (var-loc var) 'OBJECT)) - ;; already has location (e.g. optional in lambda list) - ;; check they are not the same - (unless (equal (var-loc var) loc) - (wt-nl var " = ") - (wt-coerce-loc (var-rep-type var) loc) - (wt ";"))) - ((and (consp loc) (eql (car loc) 'LCL)) - ;; set location for lambda list requireds - (setf (var-loc var) loc)) - (t - (baboon))) - ))) + ;; already has location (e.g. optional in lambda list) + ;; check they are not the same + (unless (equal (var-loc var) loc) + (wt-nl var " = ") + (wt-coerce-loc (var-rep-type var) loc) + (wt ";"))) + ((and (consp loc) (eql (car loc) 'LCL)) + ;; set location for lambda list requireds + (setf (var-loc var) loc)) + (t + (baboon))) + ))) ;;; Used by let*, defmacro and lambda's &aux, &optional, &rest, &keyword (defun bind-init (form var) (let ((kind (var-kind var))) (if (member kind '(CLOSURE LEXICAL SPECIAL GLOBAL)) - ;; Binding these variables is complicated and involves lexical - ;; environments, global environments, etc. If we use `(BIND var) - ;; as destination, BIND might receive the wrong environment. - (let* ((*inline-blocks* 0) - (*temp* *temp*) - (locs (coerce-locs (inline-args (list form))))) - (bind (first locs) var) - (close-inline-blocks) - ;; Notice that we do not need to update *UNWIND-EXIT* - ;; because BIND does it for us. - ) - ;; The simple case of a variable which is local to a function. - (let ((*destination* `(BIND ,var))) - (c2expr* form))))) + ;; Binding these variables is complicated and involves lexical + ;; environments, global environments, etc. If we use `(BIND var) + ;; as destination, BIND might receive the wrong environment. + (let* ((*inline-blocks* 0) + (*temp* *temp*) + (locs (coerce-locs (inline-args (list form))))) + (bind (first locs) var) + (close-inline-blocks) + ;; Notice that we do not need to update *UNWIND-EXIT* + ;; because BIND does it for us. + ) + ;; The simple case of a variable which is local to a function. + (let ((*destination* `(BIND ,var))) + (c2expr* form))))) (defun bds-bind (loc var) ;; Optimize the case (let ((*special-var* *special-var*)) ...) (cond ((and (var-p loc) - (member (var-kind loc) '(global special)) - (eq (var-name loc) (var-name var))) - (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) - (t - (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") - (wt-coerce-loc :object loc) - (wt ");"))) + (member (var-kind loc) '(global special)) + (eq (var-name loc) (var-name var))) + (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) + (t + (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") + (wt-coerce-loc :object loc) + (wt ");"))) (push 'BDS-BIND *unwind-exit*) (wt-comment (var-name var))) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 5f8ff85e0..ba2884a90 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -29,50 +29,50 @@ (unless (symbolp block-name) (cmperr "The block name ~s is not a symbol." block-name)) (let* ((blk-var (make-var :name block-name :kind 'LEXICAL)) - (blk (make-blk :var blk-var :name block-name)) - (body (let ((*cmp-env* (cmp-env-copy))) - (cmp-env-register-block blk) - (c1progn (rest args))))) + (blk (make-blk :var blk-var :name block-name)) + (body (let ((*cmp-env* (cmp-env-copy))) + (cmp-env-register-block blk) + (c1progn (rest args))))) (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) - (incf *setjmps*)) + (incf *setjmps*)) (if (plusp (blk-ref blk)) - ;; FIXME! By simplifying the type of a BLOCK form so much (it is - ;; either NIL or T), we lose a lot of information. - (make-c1form* 'BLOCK - :local-vars (list blk-var) - :type (values-type-or (blk-type blk) (c1form-type body)) - :args blk body) - body)))) + ;; FIXME! By simplifying the type of a BLOCK form so much (it is + ;; either NIL or T), we lose a lot of information. + (make-c1form* 'BLOCK + :local-vars (list blk-var) + :type (values-type-or (blk-type blk) (c1form-type body)) + :args blk body) + body)))) (defun c2block (c1form blk body) (declare (ignore c1form)) (if (plusp (var-ref (blk-var blk))) (let* ((blk-var (blk-var blk)) - (*env-lvl* *env-lvl*)) - (setf (blk-exit blk) *exit* - (blk-destination blk) *destination*) - (wt-nl-open-brace) - (unless (or (blk-ref-ccb blk) (blk-ref-clb blk)) - (setf (var-kind blk-var) :object - (var-loc blk-var) (next-lcl)) - (wt-nl "cl_object " blk-var ";")) - (when (env-grows (blk-ref-ccb blk)) - (let ((env-lvl *env-lvl*)) - (wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) - " = env" env-lvl ";"))) - (bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var) - (wt-nl "if (ecl_frs_push(cl_env_copy," blk-var ")!=0) {") - (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))) - (unwind-exit 'VALUES) - (wt-nl "} else {") - (c2expr body) - (wt "}")) - (when (blk-ref-ccb blk) (decf *env*)) - (wt-nl-close-brace)) + (*env-lvl* *env-lvl*)) + (setf (blk-exit blk) *exit* + (blk-destination blk) *destination*) + (wt-nl-open-brace) + (unless (or (blk-ref-ccb blk) (blk-ref-clb blk)) + (setf (var-kind blk-var) :object + (var-loc blk-var) (next-lcl)) + (wt-nl "cl_object " blk-var ";")) + (when (env-grows (blk-ref-ccb blk)) + (let ((env-lvl *env-lvl*)) + (wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) + " = env" env-lvl ";"))) + (bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var) + (wt-nl "if (ecl_frs_push(cl_env_copy," blk-var ")!=0) {") + (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))) + (unwind-exit 'VALUES) + (wt-nl "} else {") + (c2expr body) + (wt "}")) + (when (blk-ref-ccb blk) (decf *env*)) + (wt-nl-close-brace)) (progn - (setf (blk-exit blk) *exit*) - (setf (blk-destination blk) *destination*) - (c2expr body))) + (setf (blk-exit blk) *exit*) + (setf (blk-destination blk) *destination*) + (c2expr body))) ) (defun c1return-from (args) @@ -81,28 +81,28 @@ (unless (symbolp name) (cmperr "The block name ~s is not a symbol." name)) (multiple-value-bind (blk ccb clb unw) - (cmp-env-search-block name) + (cmp-env-search-block name) (unless blk - (cmperr "The block ~s is undefined." name)) + (cmperr "The block ~s is undefined." name)) (let* ((val (c1expr (second args))) - (var nil) - (type T)) - (cond (ccb (setf (blk-ref-ccb blk) t - type 'CCB - var (blk-var blk) - (var-kind var) 'CLOSURE - (var-ref-ccb var) T)) - (clb (setf (blk-ref-clb blk) t - type 'CLB - var (blk-var blk))) - (unw (setf type 'UNWIND-PROTECT - var (blk-var blk)))) - (incf (blk-ref blk)) - (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val))) - (let ((output (make-c1form* 'RETURN-FROM :type 'T - :args blk type val var))) - (when var (add-to-read-nodes var output)) - output))))) + (var nil) + (type T)) + (cond (ccb (setf (blk-ref-ccb blk) t + type 'CCB + var (blk-var blk) + (var-kind var) 'CLOSURE + (var-ref-ccb var) T)) + (clb (setf (blk-ref-clb blk) t + type 'CLB + var (blk-var blk))) + (unw (setf type 'UNWIND-PROTECT + var (blk-var blk)))) + (incf (blk-ref blk)) + (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val))) + (let ((output (make-c1form* 'RETURN-FROM :type 'T + :args blk type val var))) + (when var (add-to-read-nodes var output)) + output))))) (defun c2return-from (c1form blk type val var) (declare (ignore var c1form)) @@ -114,6 +114,6 @@ (let ((*destination* 'VALUES)) (c2expr* val)) (wt-nl "cl_return_from(" (blk-var blk) ",ECL_NIL);")) (T (let ((*destination* (blk-destination blk)) - (*exit* (blk-exit blk))) - (c2expr val)))) + (*exit* (blk-exit blk))) + (c2expr val)))) ) diff --git a/src/cmp/cmpc-inliner.lsp b/src/cmp/cmpc-inliner.lsp index 84ec23983..574e60910 100644 --- a/src/cmp/cmpc-inliner.lsp +++ b/src/cmp/cmpc-inliner.lsp @@ -26,13 +26,13 @@ (defmacro define-c-inliner (fname lambda-list &body body) `(setf (gethash ',fname *cinline-dispatch-table*) - #'(lambda ,lambda-list (block nil ,@body)))) + #'(lambda ,lambda-list (block nil ,@body)))) (defun apply-inliner (fname return-type inlined-args) (let ((fd (gethash fname *cinline-dispatch-table*))) (if fd - (apply fd return-type inlined-args) - (default-c-inliner fname return-type inlined-args)))) + (apply fd return-type inlined-args) + (default-c-inliner fname return-type inlined-args)))) (defun default-c-inliner (fname return-type inlined-args) (let* ((arg-types (mapcar #'first inlined-args)) @@ -130,7 +130,7 @@ (defun inline-type-matches (inline-info arg-types return-type) (when (and (not (inline-info-multiple-values inline-info)) - (member *destination* '(VALUES RETURN))) + (member *destination* '(VALUES RETURN))) (return-from inline-type-matches nil)) (let* ((rts nil) (number-max nil)) @@ -138,7 +138,7 @@ ;; Check that the argument types match those of the inline expression ;; (do* ((arg-types arg-types (cdr arg-types)) - (types (inline-info-arg-types inline-info) (cdr types))) + (types (inline-info-arg-types inline-info) (cdr types))) ((or (endp arg-types) (endp types)) (when (or arg-types types) (return-from inline-type-matches nil))) diff --git a/src/cmp/cmpc-machine.lsp b/src/cmp/cmpc-machine.lsp index b55b2362f..e4400d006 100644 --- a/src/cmp/cmpc-machine.lsp +++ b/src/cmp/cmpc-machine.lsp @@ -111,14 +111,14 @@ (defun make-rep-type (all-c-types name lisp-type c-name &optional to-lisp from-lisp from-lisp-unsafe) (let* ((record (assoc name all-c-types)) - (bits (cdr record))) + (bits (cdr record))) (when record ;; For integer bits we get extra information from ALL-C-TYPES (when bits - (if (plusp bits) - (setf lisp-type `(unsigned-byte ,bits)) - (setf bits (- bits) - lisp-type `(signed-byte ,bits)))) + (if (plusp bits) + (setf lisp-type `(unsigned-byte ,bits)) + (setf bits (- bits) + lisp-type `(signed-byte ,bits)))) (%make-rep-type :name name :lisp-type lisp-type @@ -136,19 +136,19 @@ (defun default-machine () (let* ((all-c-types (append +this-machine-c-types+ +all-machines-c-types+)) - (table (make-hash-table :size 128 :test 'eq)) - (sorted-rep-types - ;; Create the rep-type objects - (loop for i from 0 - for record in +representation-types+ - for rep-type = (apply #'make-rep-type all-c-types record) - when rep-type - do (setf (rep-type-index rep-type) i) - and collect (setf (gethash (rep-type-name rep-type) table) rep-type)))) + (table (make-hash-table :size 128 :test 'eq)) + (sorted-rep-types + ;; Create the rep-type objects + (loop for i from 0 + for record in +representation-types+ + for rep-type = (apply #'make-rep-type all-c-types record) + when rep-type + do (setf (rep-type-index rep-type) i) + and collect (setf (gethash (rep-type-name rep-type) table) rep-type)))) ;; hack: sse-pack -> int, but int -> int-sse-pack (let ((r (gethash :int-sse-pack table))) (when r - (setf (rep-type-index r) 'ext:int-sse-pack))) + (setf (rep-type-index r) 'ext:int-sse-pack))) ;; On a second pass, we replace types with more general ones (loop with fixnum-rep-type = (gethash ':fixnum table) with fixnum-lisp-type = (rep-type-lisp-type fixnum-rep-type) @@ -158,8 +158,8 @@ do (setf (rep-type-from-lisp-unsafe r) "ecl_fixnum")) ;; Create machine object (make-machine :c-types all-c-types - :rep-type-hash table - :sorted-types sorted-rep-types))) + :rep-type-hash table + :sorted-types sorted-rep-types))) (defun machine-c-type-p (name) (gethash name (machine-rep-type-hash *machine*))) diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 01a1e956f..d8c406be6 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -57,12 +57,12 @@ (defvar +max-depth+ 10) (defvar +c-newline-indent-strings+ #.(coerce (let ((basis (make-array (1+ +max-depth+) - :initial-element #\Space - :element-type 'base-char))) - (setf (aref basis 0) #\Newline) - (loop for i from 0 to +max-depth+ - collect (subseq basis 0 (1+ i)))) - 'vector)) + :initial-element #\Space + :element-type 'base-char))) + (setf (aref basis 0) #\Newline) + (loop for i from 0 to +max-depth+ + collect (subseq basis 0 (1+ i)))) + 'vector)) (defun wt-nl-indent () (wt1 (aref +c-newline-indent-strings+ (min *opened-c-braces* +max-depth+)))) @@ -85,9 +85,9 @@ (defun wt-nl-close-brace () (if (plusp *opened-c-braces*) (progn - (decf *opened-c-braces*) - (wt-nl-indent) - (wt1 #\})) + (decf *opened-c-braces*) + (wt-nl-indent) + (wt1 #\})) (baboon :format-control "Mismatch in C blocks"))) (defmacro with-indentation (&body body) @@ -118,8 +118,8 @@ (declare (string text)) (if single-line (progn - (fresh-line stream) - (princ "/* " stream)) + (fresh-line stream) + (princ "/* " stream)) (format stream "~50T/* ")) (let* ((l (1- (length text)))) (declare (fixnum l)) @@ -129,7 +129,7 @@ (cond ((or (eq c #\Newline) (eq c #\Tab)) (princ c stream)) - ((or (< code 32) (> code 127)) + ((or (< code 32) (> code 127)) (format stream "\ux" code)) ((and (char= c #\*) (char= (schar text (1+ n)) #\/)) (princ #\\ stream)) @@ -169,41 +169,41 @@ #+unicode (defun encode-string (string format) (let* ((output (make-array (round (* 1.2 (length string))) - :element-type 'base-char - :adjustable t - :fill-pointer 0)) - (stream (make-sequence-output-stream output :external-format format))) + :element-type 'base-char + :adjustable t + :fill-pointer 0)) + (stream (make-sequence-output-stream output :external-format format))) (write-string string stream) output)) (defun wt-filtered-data (string stream &key one-liner - (external-format #-unicode :default #+unicode :utf-8)) + (external-format #-unicode :default #+unicode :utf-8)) #+unicode (setf string (encode-string string external-format)) (let ((N (length string)) - (wt-data-column 80)) + (wt-data-column 80)) (incf *wt-string-size* N) ; 1+ accounts for a blank space (format stream (if one-liner "\"" "~%\"")) (dotimes (i N) (decf wt-data-column) (when (< wt-data-column 0) - (format stream "\"~% \"") - (setq wt-data-column 79)) + (format stream "\"~% \"") + (setq wt-data-column 79)) (let ((x (aref string i))) - (cond - ((or (< (char-code x) 32) - (> (char-code x) 127)) - (case x - ; We avoid a trailing backslash+newline because some preprocessors - ; remove them. - (#\Newline (princ "\\n" stream)) - (#\Tab (princ "\\t" stream)) - (t (format stream "\\~3,'0o" (char-code x))))) - ((char= x #\\) - (princ "\\\\" stream)) - ((char= x #\") - (princ "\\\"" stream)) - (t (princ x stream))))) + (cond + ((or (< (char-code x) 32) + (> (char-code x) 127)) + (case x + ; We avoid a trailing backslash+newline because some preprocessors + ; remove them. + (#\Newline (princ "\\n" stream)) + (#\Tab (princ "\\t" stream)) + (t (format stream "\\~3,'0o" (char-code x))))) + ((char= x #\\) + (princ "\\\\" stream)) + ((char= x #\") + (princ "\\\"" stream)) + (t (princ x stream))))) (princ "\"" stream) string)) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index d571a5dd1..cc66fcedf 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -24,49 +24,49 @@ (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) (if (<= l si::c-arguments-limit) - (make-c1form* 'FUNCALL :sp-change t :side-effects t + (make-c1form* 'FUNCALL :sp-change t :side-effects t :args (c1expr fun) (c1args* arguments)) - (unoptimized-long-call fun arguments)))) + (unoptimized-long-call fun arguments)))) (defun c1funcall (args) (check-args-number 'FUNCALL args 1) (let ((fun (first args)) - (arguments (rest args)) - fd) + (arguments (rest args)) + fd) (cond ;; (FUNCALL (LAMBDA ...) ...) ((and (consp fun) - (eq (first fun) 'LAMBDA)) - (optimize-funcall/apply-lambda (cdr fun) arguments nil)) - ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) + (eq (first fun) 'LAMBDA)) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) + ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) - (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (optimize-funcall/apply-lambda (cdr fun) arguments nil)) - ;; (FUNCALL atomic-expression ...) - ((atom fun) - (unoptimized-funcall fun arguments)) - ;; (FUNCALL macro-expression ...) - ((let ((name (first fun))) - (setq fd (and (symbolp name) + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) + ;; (FUNCALL atomic-expression ...) + ((atom fun) + (unoptimized-funcall fun arguments)) + ;; (FUNCALL macro-expression ...) + ((let ((name (first fun))) + (setq fd (and (symbolp name) ;; We do not want to macroexpand 'THE (not (eq name 'THE)) - (cmp-macro-function name)))) - (c1funcall (list* (cmp-expand-macro fd fun) arguments))) - ;; (FUNCALL lisp-expression ...) - ((not (eq (first fun) 'FUNCTION)) - (unoptimized-funcall fun arguments)) - ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) - ((si::valid-function-name-p (setq fun (second fun))) - (c1call fun arguments nil)) - ;; (FUNCALL #'(LAMBDA ...) ...) - ((and (consp fun) (eq (first fun) 'LAMBDA)) - (optimize-funcall/apply-lambda (rest fun) arguments nil)) - ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) - ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (optimize-funcall/apply-lambda (rest fun) arguments nil)) - (t - (cmperr "Malformed function name: ~A" fun))))) + (cmp-macro-function name)))) + (c1funcall (list* (cmp-expand-macro fd fun) arguments))) + ;; (FUNCALL lisp-expression ...) + ((not (eq (first fun) 'FUNCTION)) + (unoptimized-funcall fun arguments)) + ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) + ((si::valid-function-name-p (setq fun (second fun))) + (c1call fun arguments nil)) + ;; (FUNCALL #'(LAMBDA ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA)) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) + ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) + ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) + (t + (cmperr "Malformed function name: ~A" fun))))) (defun c2funcall (c1form form args) (declare (ignore c1form)) @@ -126,7 +126,7 @@ (or (fun-p fun) (and (null fun) (setf fun (find fname *global-funs* :test #'same-fname-p - :key #'fun-name))))) + :key #'fun-name))))) (return-from call-global-loc (call-loc fname fun args return-type))) ;; Call to a global (SETF ...) function @@ -139,19 +139,19 @@ (when (policy-use-direct-C-call) (let ((fd (get-sysprop fname 'Lfun))) (when fd - (multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname) - (return-from call-global-loc - (call-exported-function-loc - fname args fd minarg maxarg - (member fname *in-all-symbols-functions*) - return-type)))))) + (multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname) + (return-from call-global-loc + (call-exported-function-loc + fname args fd minarg maxarg + (member fname *in-all-symbols-functions*) + return-type)))))) (multiple-value-bind (found fd minarg maxarg) (si::mangle-name fname t) (when found (return-from call-global-loc (call-exported-function-loc fname args fd minarg maxarg t - return-type)))) + return-type)))) (call-unknown-global-loc fname nil args)) @@ -160,29 +160,29 @@ `(CALL-NORMAL ,fun ,(coerce-locs args) ,type)) (defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core - return-type) + return-type) (unless in-core ;; We only write declarations for functions which are not in lisp_external.h (multiple-value-bind (val declared) - (gethash fun-c-name *compiler-declared-globals*) + (gethash fun-c-name *compiler-declared-globals*) (declare (ignore val)) (unless declared - (if (= maxarg minarg) - (progn - (wt-nl-h "extern cl_object " fun-c-name "(") - (dotimes (i maxarg) - (when (> i 0) (wt-h1 ",")) - (wt-h1 "cl_object")) - (wt-h1 ");")) - (progn - (wt-nl-h "#ifdef __cplusplus") - (wt-nl-h "extern cl_object " fun-c-name "(...);") - (wt-nl-h "#else") - (wt-nl-h "extern cl_object " fun-c-name "();") - (wt-nl-h "#endif"))) - (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) + (if (= maxarg minarg) + (progn + (wt-nl-h "extern cl_object " fun-c-name "(") + (dotimes (i maxarg) + (when (> i 0) (wt-h1 ",")) + (wt-h1 "cl_object")) + (wt-h1 ");")) + (progn + (wt-nl-h "#ifdef __cplusplus") + (wt-nl-h "extern cl_object " fun-c-name "(...);") + (wt-nl-h "#else") + (wt-nl-h "extern cl_object " fun-c-name "();") + (wt-nl-h "#endif"))) + (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) (let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL - :minarg minarg :maxarg maxarg))) + :minarg minarg :maxarg maxarg))) (call-loc fname fun args return-type))) ;;; @@ -193,8 +193,8 @@ (defun call-unknown-global-loc (fname loc args &optional function-p) (unless loc (if (and (symbolp fname) - (not (eql (symbol-package fname) - (find-package "CL")))) + (not (eql (symbol-package fname) + (find-package "CL")))) (setf loc (add-symbol fname) function-p nil) (setf loc (list 'FDEFINITION fname) @@ -205,16 +205,16 @@ (defun maybe-save-value (value &optional (other-forms nil other-forms-flag)) (let ((name (c1form-name value))) (cond ((eq name 'LOCATION) - (c1form-arg 0 value)) - ((and (eq name 'VAR) - other-forms-flag - (not (var-changed-in-form-list (c1form-arg 0 value) other-forms))) - (c1form-arg 0 value)) - (t - (let* ((temp (make-temp-var)) - (*destination* temp)) - (c2expr* value) - temp))))) + (c1form-arg 0 value)) + ((and (eq name 'VAR) + other-forms-flag + (not (var-changed-in-form-list (c1form-arg 0 value) other-forms))) + (c1form-arg 0 value)) + (t + (let* ((temp (make-temp-var)) + (*destination* temp)) + (c2expr* value) + temp))))) (defvar *text-for-lexical-level* '("lex0" "lex1" "lex2" "lex3" "lex4" "lex5" "lex6" "lex7" "lex8" "lex9")) @@ -259,23 +259,23 @@ (unless (fun-cfun fun) (baboon "Function without a C name: ~A" (fun-name fun))) (let* ((minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (fun-c-name (fun-cfun fun)) - (fun-lisp-name (fun-name fun)) - (narg (length args)) - (env nil)) + (maxarg (fun-maxarg fun)) + (fun-c-name (fun-cfun fun)) + (fun-lisp-name (fun-name fun)) + (narg (length args)) + (env nil)) (case (fun-closure fun) (CLOSURE (setf env (environment-accessor fun))) (LEXICAL (let ((lex-lvl (fun-level fun))) - (dotimes (n lex-lvl) - (let* ((j (- lex-lvl n 1)) - (x (nth j *text-for-lexical-level*))) - (unless x - (setf x (format nil "lex~d" j) - (nth n *text-for-lexical-level*) x)) - (push x args)))))) + (dotimes (n lex-lvl) + (let* ((j (- lex-lvl n 1)) + (x (nth j *text-for-lexical-level*))) + (unless x + (setf x (format nil "lex~d" j) + (nth n *text-for-lexical-level*) x)) + (push x args)))))) (unless (<= minarg narg maxarg) (cmperr "Wrong number of arguments for function ~S" (or fun-lisp-name 'ANONYMOUS))) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 1c45cc6c7..0ce122199 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -18,32 +18,32 @@ (check-args-number 'CATCH args 1) (incf *setjmps*) (make-c1form* 'CATCH :sp-change t :type t :args (c1expr (first args)) - (c1progn (rest args)))) + (c1progn (rest args)))) (defun c2catch (c1form tag body) (declare (ignore c1form)) (let* ((new-destination (tmp-destination *destination*)) - (code (incf *last-label*))) + (code (incf *last-label*))) (let ((*destination* 'VALUE0)) (c2expr* tag)) (let* ((*destination* new-destination) - (*unwind-exit* (cons 'FRAME *unwind-exit*))) + (*unwind-exit* (cons 'FRAME *unwind-exit*))) (if (member new-destination '(TRASH VALUES)) - (progn - (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")==0) {") - (wt-comment "BEGIN CATCH ~A" code) - (with-indentation - (c2expr* body))) - (progn - (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")) {") - (wt-comment "BEGIN CATCH ~A" code) - (with-indentation - (with-exit-label (label) - (let ((*exit* label)) - (unwind-exit 'VALUES)))) - (wt-nl "} else {") - (with-indentation - (c2expr* body))))) + (progn + (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")==0) {") + (wt-comment "BEGIN CATCH ~A" code) + (with-indentation + (c2expr* body))) + (progn + (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")) {") + (wt-comment "BEGIN CATCH ~A" code) + (with-indentation + (with-exit-label (label) + (let ((*exit* label)) + (unwind-exit 'VALUES)))) + (wt-nl "} else {") + (with-indentation + (c2expr* body))))) (wt-nl "}") (wt-nl "ecl_frs_pop(cl_env_copy);") (wt-comment "END CATCH ~A" code) @@ -55,13 +55,13 @@ (let ((form (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) (c1expr (first args))))) (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t - :args form (c1progn (rest args))))) + :args form (c1progn (rest args))))) (defun c2unwind-protect (c1form form body) (declare (ignore c1form)) (let* ((sp (make-lcl-var :rep-type :cl-index)) - (nargs (make-lcl-var :rep-type :cl-index)) - (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) + (nargs (make-lcl-var :rep-type :cl-index)) + (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) (wt-nl-open-brace) (wt-nl "volatile bool unwinding = FALSE;") (wt-nl "cl_index " sp "=ECL_STACK_INDEX(cl_env_copy)," nargs ";") @@ -72,7 +72,7 @@ (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;") (wt-nl "} else {") (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) - (*destination* 'VALUES)) + (*destination* 'VALUES)) (c2expr* form)) (wt-nl "}") (wt-nl "ecl_frs_pop(cl_env_copy);") diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 386338f74..70deaf98f 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -17,32 +17,32 @@ (destructuring-bind (name return-type arg-list &rest body) args (let ((arg-types '()) - (arg-type-constants '()) - (arg-variables '()) - (c-name (format nil "ecl_callback_~d" (length *callbacks*))) - (name (if (consp name) (first name) name)) - (call-type (if (consp name) (second name) :cdecl))) + (arg-type-constants '()) + (arg-variables '()) + (c-name (format nil "ecl_callback_~d" (length *callbacks*))) + (name (if (consp name) (first name) name)) + (call-type (if (consp name) (second name) :cdecl))) (dolist (i arg-list) - (unless (consp i) - (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) - (push (first i) arg-variables) - (let ((type (second i))) - (push (second i) arg-types) - (push (if (ffi::foreign-elt-type-p type) - (foreign-elt-type-code type) - (add-object type)) - arg-type-constants))) + (unless (consp i) + (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) + (push (first i) arg-variables) + (let ((type (second i))) + (push (second i) arg-types) + (push (if (ffi::foreign-elt-type-p type) + (foreign-elt-type-code type) + (add-object type)) + arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants) call-type) - *callbacks*) + return-type (reverse arg-types) (reverse arg-type-constants) call-type) + *callbacks*) (c1expr `(progn - (defun ,name ,(reverse arg-variables) ,@body) - (si::put-sysprop ',name :callback - (list - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) - :one-liner t))))) + (defun ,name ,(reverse arg-variables) ,@body) + (si::put-sysprop ',name :callback + (list + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) + :one-liner t))))) ))) (defconstant +foreign-elt-type-codes+ @@ -82,32 +82,32 @@ (cdr x))) (defun t3-defcallback (lisp-name c-name c-name-constant return-type - arg-types arg-type-constants call-type &aux (return-p t)) + arg-types arg-type-constants call-type &aux (return-p t)) (cond ((member return-type '(nil :void)) - (setf return-p nil)) - ((ffi::foreign-elt-type-p return-type)) - ((and (consp return-type) - (member (first return-type) '(* array))) - (setf return-type :pointer-void)) - (t - (cmperr "DEFCALLBACK does not support complex return types such as ~A" - return-type))) + (setf return-p nil)) + ((ffi::foreign-elt-type-p return-type)) + ((and (consp return-type) + (member (first return-type) '(* array))) + (setf return-type :pointer-void)) + (t + (cmperr "DEFCALLBACK does not support complex return types such as ~A" + return-type))) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) - (fmod (case call-type - (:cdecl "") - (:stdcall "__stdcall ") - (t (cmperr "DEFCALLBACK does not support ~A as calling convention" - call-type))))) + (fmod (case call-type + (:cdecl "") + (:stdcall "__stdcall ") + (t (cmperr "DEFCALLBACK does not support ~A as calling convention" + call-type))))) (wt-nl-h "static " return-type-name " " fmod c-name "(") (wt-nl1 "static " return-type-name " " fmod c-name "(") (loop for n from 0 - and type in arg-types - with comma = "" - do - (progn + and type in arg-types + with comma = "" + do + (progn (wt-h comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (setf comma ","))) + (wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) + (setf comma ","))) (wt ")") (wt-h ");") (wt-nl-open-brace) @@ -117,19 +117,19 @@ (wt-nl "cl_object aux;") (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)") (loop for n from 0 - and type in arg-types - and ct in arg-type-constants - do - (if (stringp ct) - (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" + and type in arg-types + and ct in arg-type-constants + do + (if (stringp ct) + (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" n "," ct "));") - (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" + (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" n "," ct "," (ffi:size-of-foreign-type type) "));"))) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") (when return-p (wt-nl "ecl_foreign_data_set_elt(&output," - (foreign-elt-type-code return-type) ",aux);") + (foreign-elt-type-code return-type) ",aux);") (wt-nl "return output;")) (wt-nl-close-brace))) diff --git a/src/cmp/cmpclos.lsp b/src/cmp/cmpclos.lsp index 8f29c5480..04e4a6506 100644 --- a/src/cmp/cmpclos.lsp +++ b/src/cmp/cmpclos.lsp @@ -21,9 +21,9 @@ (when (fboundp fname) (let ((gf (fdefinition fname))) (when (typep gf 'standard-generic-function) - ;;(check-generic-function-args gf args) - (when (policy-inline-slot-access) - (maybe-optimize-slot-accessor fname gf args)))))) + ;;(check-generic-function-args gf args) + (when (policy-inline-slot-access) + (maybe-optimize-slot-accessor fname gf args)))))) ;;; ;;; PRECOMPUTE APPLICABLE METHODS @@ -36,12 +36,12 @@ (defun precompute-applicable-methods (methods c-args) (flet ((applicable-method-p (m) - (loop for specializer in (clos:method-specializers m) - for arg in c-args - always (let ((arg-type (c1form-type arg))) - (subtypep arg-type (if (consp specializer) - `(member ,(second specializer)) - specializer)))))) + (loop for specializer in (clos:method-specializers m) + for arg in c-args + always (let ((arg-type (c1form-type arg))) + (subtypep arg-type (if (consp specializer) + `(member ,(second specializer)) + specializer)))))) (delete-if-not #'applicable-method-p methods))) ;;; @@ -66,10 +66,10 @@ with reader-class = (find-class 'clos:standard-reader-method) with writer-class = (find-class 'clos:standard-writer-method) do (let ((method-class (class-of method))) - (cond ((si::subclassp method-class reader-class) - (push method readers)) - ((si::subclassp method-class writer-class) - (push method writers)))) + (cond ((si::subclassp method-class reader-class) + (push method readers)) + ((si::subclassp method-class writer-class) + (push method writers)))) finally (return (values readers writers)))) (defun maybe-optimize-slot-accessor (fname gf args) @@ -77,42 +77,42 @@ (find-slot-accessors gf) ;(format t "~%;;; Found ~D readers and ~D writers for ~A" (length readers) (length writers) fname) (cond ((and readers writers) - (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods" - fname)) - ((not (or readers writers)) - nil) - ((/= (length args) (length (clos::generic-function-spec-list gf))) - (cmpwarn "Too many arguments for generic function ~A" fname) - nil) - (readers - (try-optimize-slot-reader readers args)) - (writers - (try-optimize-slot-writer writers args))))) + (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods" + fname)) + ((not (or readers writers)) + nil) + ((/= (length args) (length (clos::generic-function-spec-list gf))) + (cmpwarn "Too many arguments for generic function ~A" fname) + nil) + (readers + (try-optimize-slot-reader readers args)) + (writers + (try-optimize-slot-writer writers args))))) (defun try-optimize-slot-reader (readers args) (let* ((object (first args)) - (c-object (c1expr object)) - (readers (precompute-applicable-methods readers (list c-object)))) + (c-object (c1expr object)) + (readers (precompute-applicable-methods readers (list c-object)))) ;(format t "~%;;; Found ~D really applicable reader" (length readers)) (when (= (length readers) 1) (let ((reader (first readers))) - (when (typep reader 'clos:standard-reader-method) - (let* ((slotd (clos:accessor-method-slot-definition reader)) - (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) - `(clos::safe-instance-ref ,object ,index)))))))) + (when (typep reader 'clos:standard-reader-method) + (let* ((slotd (clos:accessor-method-slot-definition reader)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + `(clos::safe-instance-ref ,object ,index)))))))) (defun try-optimize-slot-writer (orig-writers args) (let* ((c-args (mapcar #'c1expr args)) - (writers (precompute-applicable-methods orig-writers c-args))) + (writers (precompute-applicable-methods orig-writers c-args))) ;(format t "~%;;; Found ~D really applicable writer" (length writers)) (when (= (length writers) 1) (let ((writer (first writers))) - (when (typep writer 'clos:standard-writer-method) - (let* ((slotd (clos:accessor-method-slot-definition writer)) - (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) - `(si::instance-set ,(second args) ,index ,(first args))))))))) + (when (typep writer 'clos:standard-writer-method) + (let* ((slotd (clos:accessor-method-slot-definition writer)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + `(si::instance-set ,(second args) ,index ,(first args))))))))) #+(or) (progn . @@ -128,5 +128,5 @@ when accessor collect `(define-compiler-macro ,accessor (&whole whole obj &environment env) (if (policy-inline-slot-access env) - `(clos::safe-instance-ref ,obj ,,i) + `(clos::safe-instance-ref ,obj ,,i) whole))))) diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index 3510b8cd2..93e809c56 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -30,29 +30,29 @@ (make-c1form* 'LOCATION :type 'FIXNUM :args (list 'FIXNUM-VALUE val))) ((characterp val) (make-c1form* 'LOCATION :type 'CHARACTER - :args (list 'CHARACTER-VALUE (char-code val)))) + :args (list 'CHARACTER-VALUE (char-code val)))) ((typep val 'DOUBLE-FLOAT) (when (and (ext:float-nan-p val) (not only-small-values)) (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'DOUBLE-FLOAT - :args (list 'DOUBLE-FLOAT-VALUE val (add-object val)))) + :args (list 'DOUBLE-FLOAT-VALUE val (add-object val)))) ((typep val 'SINGLE-FLOAT) (when (and (ext:float-nan-p val) (not only-small-values)) (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'SINGLE-FLOAT - :args (list 'SINGLE-FLOAT-VALUE val (add-object val)))) + :args (list 'SINGLE-FLOAT-VALUE val (add-object val)))) ((typep val 'LONG-FLOAT) (when (and (ext:float-nan-p val) (not only-small-values)) (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'LONG-FLOAT - :args (list 'LONG-FLOAT-VALUE val (add-object val)))) + :args (list 'LONG-FLOAT-VALUE val (add-object val)))) #+sse2 ((typep val 'EXT:SSE-PACK) (c1constant-value/sse val)) (only-small-values nil) (always (make-c1form* 'LOCATION :type (object-type val) - :args (add-object val))) + :args (add-object val))) (t nil))) #+sse2 @@ -65,9 +65,9 @@ (double-float (values "_mm_castsi128_pd" :double-sse-pack)) (otherwise (values "" :int-sse-pack))) `(c-inline () () ,rtype - ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" - wrapper (coerce bytes 'list)) - :one-liner t :side-effects nil)))) + ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" + wrapper (coerce bytes 'list)) + :one-liner t :side-effects nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -76,24 +76,24 @@ (defun make-single-constant-optimizer (name c-value) (cond ((symbolp name) - (let* ((value (symbol-value name)) - (type (lisp-type->rep-type (type-of value)))) - (cons value `(c-inline () () ,type ,c-value - :one-liner t :side-effects nil)))) - ((floatp name) - (let* ((value name) + (let* ((value (symbol-value name)) + (type (lisp-type->rep-type (type-of value)))) + (cons value `(c-inline () () ,type ,c-value + :one-liner t :side-effects nil)))) + ((floatp name) + (let* ((value name) (type (type-of value)) - (loc-type (case type - (single-float 'single-float-value) - (double-float 'double-float-value) - (long-float 'long-float-value))) - (location (make-vv :location c-value :value value))) - (cons value (make-c1form* 'LOCATION :type type - :args (list loc-type value location))))) - (t - (cons name (make-c1form* 'LOCATION :type (type-of name) - :args (make-vv :location c-value - :value name)))))) + (loc-type (case type + (single-float 'single-float-value) + (double-float 'double-float-value) + (long-float 'long-float-value))) + (location (make-vv :location c-value :value value))) + (cons value (make-c1form* 'LOCATION :type type + :args (list loc-type value location))))) + (t + (cons name (make-c1form* 'LOCATION :type (type-of name) + :args (make-vv :location c-value + :value name)))))) (defun make-optimizable-constants (machine) (loop for (value name) in (optimizable-constants-list machine) @@ -152,10 +152,10 @@ #+long-float ,@'( - (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") - (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") - (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN") - (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") - (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN") - (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") - ))))) + (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") + (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") + (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN") + (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") + (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN") + (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") + ))))) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index ba999a3a1..82f1d352b 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -32,37 +32,37 @@ that are susceptible to be changed by PROCLAIM." #-new-cmp (defun cmp-env-cleanups (env) (loop with specials = '() - with end = (cmp-env-variables env) - with cleanup-forms = '() - with aux - for records-list on (cmp-env-variables *cmp-env*) - until (eq records-list end) - do (let ((record (first records-list))) - (cond ((atom record)) - ((and (symbolp (first record)) - (eq (second record) :special)) - (push (fourth record) specials)) - ((eq (first record) :cleanup) - (push (second record) cleanup-forms)))) - finally (progn - (unless (eq records-list end) - (error "Inconsistency in environment.")) - (return (values specials + with end = (cmp-env-variables env) + with cleanup-forms = '() + with aux + for records-list on (cmp-env-variables *cmp-env*) + until (eq records-list end) + do (let ((record (first records-list))) + (cond ((atom record)) + ((and (symbolp (first record)) + (eq (second record) :special)) + (push (fourth record) specials)) + ((eq (first record) :cleanup) + (push (second record) cleanup-forms)))) + finally (progn + (unless (eq records-list end) + (error "Inconsistency in environment.")) + (return (values specials (apply #'nconc (mapcar #'copy-list cleanup-forms))))))) (defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) (push (list (var-name var) - (if (member (var-kind var) '(special global)) - :special - t) - boundp - var) - (cmp-env-variables env)) + (if (member (var-kind var) '(special global)) + :special + t) + boundp + var) + (cmp-env-variables env)) env) (defun cmp-env-declare-special (name &optional (env *cmp-env*)) (cmp-env-register-var (c::c1make-global-variable name :warn nil :kind 'SPECIAL) - env nil) + env nil) env) (defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*)) @@ -77,7 +77,7 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-register-function (fun &optional (env *cmp-env*)) (push (list (fun-name fun) 'function fun) - (cmp-env-functions env)) + (cmp-env-functions env)) env) (defun cmp-env-register-global-macro (name function) @@ -87,7 +87,7 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-register-macro (name function &optional (env *cmp-env*)) (push (list name 'si::macro function) - (cmp-env-functions env)) + (cmp-env-functions env)) env) (defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*)) @@ -97,18 +97,18 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*)) (push (list name 'si::symbol-macro - #'(lambda (whole env) (declare (ignore env whole)) form)) - (cmp-env-variables env)) + #'(lambda (whole env) (declare (ignore env whole)) form)) + (cmp-env-variables env)) env) (defun cmp-env-register-block (blk &optional (env *cmp-env*)) (push (list :block (blk-name blk) blk) - (cmp-env-variables env)) + (cmp-env-variables env)) env) (defun cmp-env-register-tag (name tag &optional (env *cmp-env*)) (push (list :tag (list name) tag) - (cmp-env-variables env)) + (cmp-env-variables env)) env) (defun cmp-env-register-cleanup (form &optional (env *cmp-env*)) @@ -117,56 +117,56 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-search-function (name &optional (env *cmp-env*)) (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) + (clb nil) + (unw nil) + (found nil)) (dolist (record (cmp-env-functions env)) (cond ((eq record 'CB) - (setf ccb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon :format-control "Uknown record found in environment~%~S" + (setf ccb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon :format-control "Uknown record found in environment~%~S" :format-arguments (list record))) - ;; We have to use EQUAL because the name can be a list (SETF whatever) - ((equal (first record) name) - (setf found (first (last record))) - (return)))) + ;; We have to use EQUAL because the name can be a list (SETF whatever) + ((equal (first record) name) + (setf found (first (last record))) + (return)))) (values found ccb clb unw))) (defun cmp-env-search-variables (type name env) (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) + (clb nil) + (unw nil) + (found nil)) (dolist (record (cmp-env-variables env)) (cond ((eq record 'CB) - (setf ccb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon :format-control "Uknown record found in environment~%~S" + (setf ccb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon :format-control "Uknown record found in environment~%~S" :format-arguments (list record))) - ((not (eq (first record) type))) - ((eq type :block) - (when (eq name (second record)) - (setf found record) - (return))) - ((eq type :tag) - (when (member name (second record) :test #'eql) - (setf found record) - (return))) - ((eq (second record) 'si::symbol-macro) - (when (eq name 'si::symbol-macro) - (setf found record)) - (return)) - (t - (setf found record) - (return)))) + ((not (eq (first record) type))) + ((eq type :block) + (when (eq name (second record)) + (setf found record) + (return))) + ((eq type :tag) + (when (member name (second record) :test #'eql) + (setf found record) + (return))) + ((eq (second record) 'si::symbol-macro) + (when (eq name 'si::symbol-macro) + (setf found record)) + (return)) + (t + (setf found record) + (return)))) (values (first (last found)) ccb clb unw))) (defun cmp-env-search-block (name &optional (env *cmp-env*)) @@ -194,13 +194,13 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-mark (mark &optional (env *cmp-env*)) (cons (cons mark (car env)) - (cons mark (cdr env)))) + (cons mark (cdr env)))) (defun cmp-env-new-variables (new-env old-env) (loop for i in (ldiff (cmp-env-variables new-env) - (cmp-env-variables old-env)) - when (and (consp i) (var-p (fourth i))) - collect (fourth i))) + (cmp-env-variables old-env)) + when (and (consp i) (var-p (fourth i))) + collect (fourth i))) (defun cmp-env-search-declaration (kind &optional (env *cmp-env*) default) (loop for i in (car env) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index 54c546681..a1efce1d4 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -39,7 +39,7 @@ (defun alien-declaration-p (name &optional (env *cmp-env*)) (and (symbolp name) (member name (cmp-env-search-declaration 'alien env si::*alien-declarations*) - :test 'eq))) + :test 'eq))) (defun parse-ignore-declaration (decl-args expected-ref-number tail) (declare (si::c-local)) @@ -73,9 +73,9 @@ and a possible documentation string (only accepted when DOC-P is true)." for decl-name = (first decl) for decl-args = (rest decl) do (cmpassert (and (valid-form-p decl-args) - (or (symbolp decl-name) - (and (consp decl-name) - (valid-type-specifier decl-name)))) + (or (symbolp decl-name) + (and (consp decl-name) + (valid-type-specifier decl-name)))) "Syntax error in declaration ~s" decl) do (case decl-name (SPECIAL) @@ -102,15 +102,15 @@ and a possible documentation string (only accepted when DOC-P is true)." SI::C-GLOBAL DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY) (push decl others)) - (SI:FUNCTION-BLOCK-NAME) + (SI:FUNCTION-BLOCK-NAME) (otherwise (if (or (alien-declaration-p decl-name) (policy-declaration-name-p decl-name)) (push decl others) (multiple-value-bind (ok type) - (if (machine-c-type-p decl-name) - (values t decl-name) - (valid-type-specifier decl-name)) + (if (machine-c-type-p decl-name) + (values t decl-name) + (valid-type-specifier decl-name)) (cmpassert ok "Unknown declaration specifier ~s" decl-name) (setf types (collect-declared type decl-args types)))))) diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index a34210bda..46082d480 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -23,40 +23,40 @@ (push (car al) types))) ;;; The valid return type declaration is: -;;; (( VALUES {type}* )) or ( {type}* ). +;;; (( VALUES {type}* )) or ( {type}* ). (defun proclaim-function (fname decl) (if (si:valid-function-name-p fname) (let* ((arg-types '*) - (return-types '*) - (l decl)) - (cond ((null l)) - ((consp l) - (setf arg-types (pop l))) - (t (warn "The function proclamation ~s ~s is not valid." - fname decl))) - (cond ((null l)) - ((or (atom l) (rest l)) - (warn "The function proclamation ~s ~s is not valid." - fname decl)) - (t - (setf return-types (first l)))) + (return-types '*) + (l decl)) + (cond ((null l)) + ((consp l) + (setf arg-types (pop l))) + (t (warn "The function proclamation ~s ~s is not valid." + fname decl))) + (cond ((null l)) + ((or (atom l) (rest l)) + (warn "The function proclamation ~s ~s is not valid." + fname decl)) + (t + (setf return-types (first l)))) (when (eq arg-types '()) (setf arg-types '(&optional))) - (if (eq arg-types '*) - (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) - (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) - (if (member return-types '(* (VALUES &rest t)) + (if (eq arg-types '*) + (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) + (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) + (if (member return-types '(* (VALUES &rest t)) :test #'equalp) - (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) - (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) + (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) + (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) (warn "The function proclamation ~s ~s is not valid." fname decl))) (defun add-function-declaration (fname ftype &optional (env *cmp-env*)) (if (si::valid-function-name-p fname) (let ((fun (cmp-env-search-function fname))) - (if (functionp fun) - (warn "Found function declaration for local macro ~A" fname) + (if (functionp fun) + (warn "Found function declaration for local macro ~A" fname) (cmp-env-register-ftype fname ftype env))) (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)) env) @@ -64,9 +64,9 @@ (defun get-arg-types (fname &optional (env *cmp-env*) (may-be-global t)) (let ((x (cmp-env-search-ftype fname env))) (if x - (let ((arg-types (first x))) - (unless (eq arg-types '*) - (values arg-types t))) + (let ((arg-types (first x))) + (unless (eq arg-types '*) + (values arg-types t))) (when may-be-global (let ((fun (cmp-env-search-function fname env))) (when (or (null fun) (and (fun-p fun) (fun-global fun))) @@ -75,9 +75,9 @@ (defun get-return-type (fname &optional (env *cmp-env*)) (let ((x (cmp-env-search-ftype fname env))) (if x - (let ((return-types (second x))) - (unless (eq return-types '*) - (values return-types t))) + (let ((return-types (second x))) + (unless (eq return-types '*) + (values return-types t))) (let ((fun (cmp-env-search-function fname env))) (when (or (null fun) (and (fun-p fun) (fun-global fun))) (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))))) @@ -98,21 +98,21 @@ (multiple-value-bind (arg-list found) (get-arg-types fun env) (if found - (loop for type in arg-list - with minarg = 0 - and maxarg = 0 - and in-optionals = nil - do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) - (return (values minarg call-arguments-limit))) - ((eq type '&optional) - (setf in-optionals t maxarg minarg)) - (in-optionals - (incf maxarg)) - (t - (incf minarg) - (incf maxarg))) - finally (return (values minarg maxarg found))) - (values 0 call-arguments-limit found)))) + (loop for type in arg-list + with minarg = 0 + and maxarg = 0 + and in-optionals = nil + do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) + (return (values minarg call-arguments-limit))) + ((eq type '&optional) + (setf in-optionals t maxarg minarg)) + (in-optionals + (incf maxarg)) + (t + (incf minarg) + (incf maxarg))) + finally (return (values minarg maxarg found))) + (values 0 call-arguments-limit found)))) ;;; Proclamation and declaration handling. @@ -144,15 +144,15 @@ (let* ((x (cmp-env-search-declaration 'inline env)) (flag (assoc fname x :test #'same-fname-p))) (if flag - (cdr flag) - (sys:get-sysprop fname 'INLINE)))) + (cdr flag) + (sys:get-sysprop fname 'INLINE)))) (defun declared-notinline-p (fname &optional (env *cmp-env*)) (let* ((x (cmp-env-search-declaration 'inline env)) (flag (assoc fname x :test #'same-fname-p))) (if flag - (null (cdr flag)) - (sys:get-sysprop fname 'NOTINLINE)))) + (null (cdr flag)) + (sys:get-sysprop fname 'NOTINLINE)))) (defun inline-possible (fname &optional (env *cmp-env*)) (not (declared-notinline-p fname env))) @@ -163,14 +163,14 @@ ;;; a symbol property. (defun maybe-install-inline-function (fname form env) (let* ((x (cmp-env-search-declaration 'inline env)) - (flag (assoc fname x :test #'same-fname-p)) - (declared (and flag (cdr flag))) - (proclaimed (sys:get-sysprop fname 'inline))) + (flag (assoc fname x :test #'same-fname-p)) + (declared (and flag (cdr flag))) + (proclaimed (sys:get-sysprop fname 'inline))) `(progn ,(when declared - `(eval-when (:compile-toplevel) - (c::declare-inline ',fname *cmp-env-root* ',form))) + `(eval-when (:compile-toplevel) + (c::declare-inline ',fname *cmp-env-root* ',form))) ,(when proclaimed - `(eval-when (:compile-toplevel :load-toplevel :execute) - (si::put-sysprop ',fname 'inline ',form)))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (si::put-sysprop ',fname 'inline ',form)))))) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 7dc0179c1..24f702bda 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -26,7 +26,7 @@ #-:CCL (defun proclaim (decl &aux decl-name) (unless (listp decl) - (error "The proclamation specification ~s is not a list" decl)) + (error "The proclamation specification ~s is not a list" decl)) (case (setf decl-name (car decl)) (SPECIAL (dolist (var (cdr decl)) @@ -42,7 +42,7 @@ (not (<= 0 (second x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) - (DEBUG (setq *debug* (second x))) + (DEBUG (setq *debug* (second x))) (SAFETY (setq *safety* (second x))) (SPACE (setq *space* (second x))) (SPEED (setq *speed* (second x))) @@ -54,14 +54,14 @@ (error "Syntax error in proclamation ~s" decl))) (FTYPE (if (atom (rest decl)) - (error "Syntax error in proclamation ~a" decl) - (multiple-value-bind (type-name args) - (si::normalize-type (second decl)) - (if (eq type-name 'FUNCTION) - (dolist (v (cddr decl)) - (proclaim-function v args)) - (error "In an FTYPE proclamation, found ~A which is not a function type." - (second decl)))))) + (error "Syntax error in proclamation ~a" decl) + (multiple-value-bind (type-name args) + (si::normalize-type (second decl)) + (if (eq type-name 'FUNCTION) + (dolist (v (cddr decl)) + (proclaim-function v args)) + (error "In an FTYPE proclamation, found ~A which is not a function type." + (second decl)))))) (INLINE (proclaim-inline (cdr decl))) (NOTINLINE @@ -70,25 +70,25 @@ ;; FIXME! IGNORED! (dolist (var (cdr decl)) (unless (si::valid-function-name-p var) - (error "Not a valid function name ~s in ~s proclamation" var decl-name)))) + (error "Not a valid function name ~s in ~s proclamation" var decl-name)))) (DECLARATION (validate-alien-declaration (rest decl) #'error) (setf si::*alien-declarations* (append (rest decl) si:*alien-declarations*))) (SI::C-EXPORT-FNAME (dolist (x (cdr decl)) (cond ((symbolp x) - (multiple-value-bind (found c-name) - (si::mangle-name x t) - (if found - (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x) - (put-sysprop x 'Lfun c-name)))) - ((consp x) - (destructuring-bind (c-name lisp-name) x - (if (si::mangle-name lisp-name) - (warn "The funciton ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name) - (put-sysprop lisp-name 'Lfun c-name)))) - (t - (error "Syntax error in proclamation ~s" decl))))) + (multiple-value-bind (found c-name) + (si::mangle-name x t) + (if found + (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x) + (put-sysprop x 'Lfun c-name)))) + ((consp x) + (destructuring-bind (c-name lisp-name) x + (if (si::mangle-name lisp-name) + (warn "The funciton ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name) + (put-sysprop lisp-name 'Lfun c-name)))) + (t + (error "Syntax error in proclamation ~s" decl))))) ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL @@ -98,29 +98,29 @@ (proclaim-var decl-name (cdr decl))) (otherwise (cond ((member (car decl) si:*alien-declarations*)) - ((multiple-value-bind (ok type) - (valid-type-specifier decl-name) - (when ok - (proclaim-var type (rest decl)) - t))) + ((multiple-value-bind (ok type) + (valid-type-specifier decl-name) + (when ok + (proclaim-var type (rest decl)) + t))) ((maybe-add-policy decl *cmp-env-root*)) - ((let ((proclaimer (get-sysprop (car decl) :proclaim))) - (when (functionp proclaimer) - (mapc proclaimer (rest decl)) - t))) - (t - (warn "Unknown declaration specifier ~s" decl-name)))))) + ((let ((proclaimer (get-sysprop (car decl) :proclaim))) + (when (functionp proclaimer) + (mapc proclaimer (rest decl)) + t))) + (t + (warn "Unknown declaration specifier ~s" decl-name)))))) (defun proclaim-var (type vl) (dolist (var vl) (if (symbolp var) - (let ((type1 (get-sysprop var 'CMP-TYPE))) - (setq type1 (if type1 (type-and type1 type) type)) - (unless type1 - (warn - "Inconsistent type declaration was found for the variable ~s." - var) - (setq type1 T)) - (put-sysprop var 'CMP-TYPE type1)) - (warn "The variable name ~s is not a symbol." var)))) + (let ((type1 (get-sysprop var 'CMP-TYPE))) + (setq type1 (if type1 (type-and type1 type) type)) + (unless type1 + (warn + "Inconsistent type declaration was found for the variable ~s." + var) + (setq type1 T)) + (put-sysprop var 'CMP-TYPE type1)) + (warn "The variable name ~s is not a symbol." var)))) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 7bf4c15d9..fc29c38cb 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -17,38 +17,38 @@ (defun c1expr-inner (form) (declare (si::c-local)) (cond ((symbolp form) - (setq form (chk-symbol-macrolet form)) - (cond ((not (symbolp form)) - form) - ((eq form nil) (c1nil)) - ((eq form t) (c1t)) - ((keywordp form) - (make-c1form* 'LOCATION :type (object-type form) - :args (add-symbol form))) - ((constantp form) - (or (c1constant-value (symbol-value form) :only-small-values t) - (c1var form))) - (t (c1var form)))) - ((consp form) - (cmpck (not (si::proper-list-p form)) - "Improper list found in lisp form~%~A" form) - (let ((fun (car form))) - (cond ((let ((fd (gethash fun *c1-dispatch-table*))) - (and fd (setf fun fd))) - (funcall fun (rest form))) - ((symbolp fun) - (c1call fun (cdr form) t)) - ((and (consp fun) (eq (car fun) 'LAMBDA)) - (c1funcall form)) - (t (cmperr "~s is not a legal function name." fun))))) - (t (c1constant-value form :always t)))) + (setq form (chk-symbol-macrolet form)) + (cond ((not (symbolp form)) + form) + ((eq form nil) (c1nil)) + ((eq form t) (c1t)) + ((keywordp form) + (make-c1form* 'LOCATION :type (object-type form) + :args (add-symbol form))) + ((constantp form) + (or (c1constant-value (symbol-value form) :only-small-values t) + (c1var form))) + (t (c1var form)))) + ((consp form) + (cmpck (not (si::proper-list-p form)) + "Improper list found in lisp form~%~A" form) + (let ((fun (car form))) + (cond ((let ((fd (gethash fun *c1-dispatch-table*))) + (and fd (setf fun fd))) + (funcall fun (rest form))) + ((symbolp fun) + (c1call fun (cdr form) t)) + ((and (consp fun) (eq (car fun) 'LAMBDA)) + (c1funcall form)) + (t (cmperr "~s is not a legal function name." fun))))) + (t (c1constant-value form :always t)))) (defun c1expr (form) (let ((*current-form* form)) (loop (setf form (c1expr-inner form)) (when (c1form-p form) - (return form))))) + (return form))))) (defvar *c1nil* (make-c1form* 'LOCATION :type (object-type nil) :args nil)) (defun c1nil () *c1nil*) @@ -57,69 +57,69 @@ (defun c1call (fname args macros-allowed &aux fd success can-inline) (cond ((> (length args) si::c-arguments-limit) - (if (and macros-allowed - (setf fd (cmp-macro-function fname))) - (cmp-expand-macro fd (list* fname args)) - ;; When it is a function and takes many arguments, we will - ;; need a special C form to call it. It takes extra code for - ;; handling the stack - (unoptimized-long-call `#',fname args))) - ((setq fd (local-function-ref fname)) - (c1call-local fname fd args)) - ((and (setq can-inline (inline-possible fname)) - (setq fd (compiler-macro-function fname)) - (progn - (multiple-value-setq (fd success) - (cmp-expand-compiler-macro fd fname args)) - success)) - fd) - ((and can-inline - (progn - (multiple-value-setq (fd success) - (clos-compiler-macro-expand fname args)) - success)) - fd) - ((and macros-allowed - (setq fd (cmp-macro-function fname))) - (cmp-expand-macro fd (list* fname args))) - ((and (setq can-inline (declared-inline-p fname)) - (consp can-inline) - (eq (first can-inline) 'function) - (plusp *inline-max-depth*) - (<= (cmp-env-optimization 'space) 1)) - (let ((*inline-max-depth* (1- *inline-max-depth*))) - (cmpnote "Inlining ~a" fname) - `(funcall ,can-inline ,@args))) - (t (c1call-global fname args)))) + (if (and macros-allowed + (setf fd (cmp-macro-function fname))) + (cmp-expand-macro fd (list* fname args)) + ;; When it is a function and takes many arguments, we will + ;; need a special C form to call it. It takes extra code for + ;; handling the stack + (unoptimized-long-call `#',fname args))) + ((setq fd (local-function-ref fname)) + (c1call-local fname fd args)) + ((and (setq can-inline (inline-possible fname)) + (setq fd (compiler-macro-function fname)) + (progn + (multiple-value-setq (fd success) + (cmp-expand-compiler-macro fd fname args)) + success)) + fd) + ((and can-inline + (progn + (multiple-value-setq (fd success) + (clos-compiler-macro-expand fname args)) + success)) + fd) + ((and macros-allowed + (setq fd (cmp-macro-function fname))) + (cmp-expand-macro fd (list* fname args))) + ((and (setq can-inline (declared-inline-p fname)) + (consp can-inline) + (eq (first can-inline) 'function) + (plusp *inline-max-depth*) + (<= (cmp-env-optimization 'space) 1)) + (let ((*inline-max-depth* (1- *inline-max-depth*))) + (cmpnote "Inlining ~a" fname) + `(funcall ,can-inline ,@args))) + (t (c1call-global fname args)))) (defun c1call-local (fname fun args) (declare (si::c-local)) (let ((lambda (fun-lambda-expression fun))) (when (and lambda - (declared-inline-p fname) - (plusp *inline-max-depth*)) + (declared-inline-p fname) + (plusp *inline-max-depth*)) (return-from c1call-local - (let ((*inline-max-depth* (1- *inline-max-depth*))) - `(funcall #',lambda ,@args))))) + (let ((*inline-max-depth* (1- *inline-max-depth*))) + `(funcall #',lambda ,@args))))) (let* ((forms (c1args* args)) - (return-type (or (get-local-return-type fun) 'T)) - (arg-types (get-local-arg-types fun))) + (return-type (or (get-local-return-type fun) 'T)) + (arg-types (get-local-arg-types fun))) ;; Add type information to the arguments. (when arg-types (let ((fl nil)) - (dolist (form forms) - (cond ((endp arg-types) (push form fl)) - (t (push (and-form-type (car arg-types) form (car args) - :safe "In a call to ~a" fname) - fl) - (pop arg-types) - (pop args)))) - (setq forms (nreverse fl)))) + (dolist (form forms) + (cond ((endp arg-types) (push form fl)) + (t (push (and-form-type (car arg-types) form (car args) + :safe "In a call to ~a" fname) + fl) + (pop arg-types) + (pop args)))) + (setq forms (nreverse fl)))) (make-c1form* 'CALL-LOCAL - :sp-change t ; conservative estimate - :side-effects t ; conservative estimate - :type return-type - :args fun forms))) + :sp-change t ; conservative estimate + :side-effects t ; conservative estimate + :type return-type + :args fun forms))) (defun c1call-global (fname args) (let* ((forms (c1args* args))) @@ -128,33 +128,33 @@ ;; is not printable. (let ((value (c1call-constant-fold fname forms))) (when value - (return-from c1call-global value))) + (return-from c1call-global value))) ;; Otherwise emit a global function call (make-c1form* 'CALL-GLOBAL - :sp-change (function-may-change-sp fname) - :side-effects (function-may-have-side-effects fname) - :type (propagate-types fname forms) - :args fname forms - ;; loc and type are filled by c2expr - ))) + :sp-change (function-may-change-sp fname) + :side-effects (function-may-have-side-effects fname) + :type (propagate-types fname forms) + :args fname forms + ;; loc and type are filled by c2expr + ))) (defun c1call-constant-fold (fname forms) (when (and (get-sysprop fname 'pure) - (policy-evaluate-forms) - (inline-possible fname)) + (policy-evaluate-forms) + (inline-possible fname)) (handler-case - (loop with all-values = '() - with constant-p - with v - for form in forms - do (if (multiple-value-setq (constant-p v) - (c1form-constant-p form)) - (push v all-values) - (return nil)) - finally - (return (c1constant-value - (apply fname (nreverse all-values)) - :only-small-values nil))) + (loop with all-values = '() + with constant-p + with v + for form in forms + do (if (multiple-value-setq (constant-p v) + (c1form-constant-p form)) + (push v all-values) + (return nil)) + finally + (return (c1constant-value + (apply fname (nreverse all-values)) + :only-small-values nil))) (error (c))))) (defun c2expr (form) @@ -171,10 +171,10 @@ ;; the point where the next form will be compiled. (with-exit-label (label) (let* ((*exit* label) - (*unwind-exit* (cons *exit* *unwind-exit*)) - ;;(*lex* *lex*) - (*lcl* *lcl*) - (*temp* *temp*)) + (*unwind-exit* (cons *exit* *unwind-exit*)) + ;;(*lex* *lex*) + (*lcl* *lcl*) + (*temp* *temp*)) (c2expr form)))) (defun c1with-backend (forms) @@ -186,11 +186,11 @@ (defun c1progn (forms) (cond ((endp forms) (t1/c1expr 'NIL)) - ((endp (cdr forms)) (t1/c1expr (car forms))) - (t (let* ((fl (mapcar #'t1/c1expr forms)) - (output-form (first (last fl))) - (output-type (and output-form (c1form-type output-form)))) - (make-c1form* 'PROGN :type output-type :args fl))))) + ((endp (cdr forms)) (t1/c1expr (car forms))) + (t (let* ((fl (mapcar #'t1/c1expr forms)) + (output-form (first (last fl))) + (output-type (and output-form (c1form-type output-form)))) + (make-c1form* 'PROGN :type output-type :args fl))))) (defun c2progn (c1form forms) (declare (ignore c1form)) @@ -200,14 +200,14 @@ ((endp (cdr l)) (c2expr (car l))) (let* ((this-form (first l)) - (name (c1form-name this-form))) + (name (c1form-name this-form))) (let ((*destination* 'TRASH)) - (c2expr* (car l))) - (setq *lex* lex) ; recycle lex locations + (c2expr* (car l))) + (setq *lex* lex) ; recycle lex locations ;; Since PROGN does not have tags, any transfer of control means ;; leaving the current PROGN statement. (when (or (eq name 'GO) (eq name 'RETURN-FROM)) - (return))))) + (return))))) (defun c1args* (forms) (mapcar #'c1expr forms)) @@ -215,22 +215,22 @@ ;;; ---------------------------------------------------------------------- (defvar *compiler-temps* - '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) + '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) (defmacro sys::define-inline-function (name vars &body body) (let ((temps nil) - (*compiler-temps* *compiler-temps*)) + (*compiler-temps* *compiler-temps*)) (dolist (var vars) (if (and (symbolp var) - (not (member var '(&OPTIONAL &REST &KEY &AUX) :test #'eq))) - (push (or (pop *compiler-temps*) - (gentemp "TMP" (find-package 'COMPILER))) - temps) - (error "The parameter ~s for the inline function ~s is illegal." - var name))) + (not (member var '(&OPTIONAL &REST &KEY &AUX) :test #'eq))) + (push (or (pop *compiler-temps*) + (gentemp "TMP" (find-package 'COMPILER))) + temps) + (error "The parameter ~s for the inline function ~s is illegal." + var name))) (let ((binding (cons 'LIST (mapcar - #'(lambda (var temp) `(list ',var ,temp)) - vars temps)))) + #'(lambda (var temp) `(list ',var ,temp)) + vars temps)))) `(progn - (defun ,name ,vars ,@body) - (define-compiler-macro ,name ,temps (list* 'LET ,binding ',body)))))) + (defun ,name ,vars ,@body) + (define-compiler-macro ,name ,temps (list* 'LET ,binding ',body)))))) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index eecae98c2..802fca5d8 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -14,19 +14,19 @@ (in-package "COMPILER") -;;; UNWIND-EXIT TAGS PURPOSE +;;; UNWIND-EXIT TAGS PURPOSE ;;; -;;; number -> unknown purpose -;;; JUMP -> unknown purpose -;;; FRAME -> ecl_frs_push() -;;; IHS -> ihs push -;;; IHS-ENV -> ihs push -;;; BDS-BIND -> binding of 1 special variable -;;; (number . {T|NIL}) -> label -;;; (LCL n) -> n local variables -;;; (STACK n) -> n elements pushed in stack -;;; TAIL-RECURSION-MARK -> TTL: label created -;;; RETURN* -> outermost location +;;; number -> unknown purpose +;;; JUMP -> unknown purpose +;;; FRAME -> ecl_frs_push() +;;; IHS -> ihs push +;;; IHS-ENV -> ihs push +;;; BDS-BIND -> binding of 1 special variable +;;; (number . {T|NIL}) -> label +;;; (LCL n) -> n local variables +;;; (STACK n) -> n elements pushed in stack +;;; TAIL-RECURSION-MARK -> TTL: label created +;;; RETURN* -> outermost location ;;; ;;; (*) also RETURN-FIXNUM, -CHARACTER, -SINGLE-FLOAT ;;; -DOUBLE-FLOAT, -OBJECT. @@ -37,19 +37,19 @@ (when stack-frame (setf some t) (if (stringp stack-frame) - (wt-nl "ecl_stack_frame_close(" stack-frame ");") - (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");"))) + (wt-nl "ecl_stack_frame_close(" stack-frame ");") + (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");"))) (when bds-lcl (setf some t) (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");")) (cond ((< bds-bind 4) - (dotimes (n bds-bind) - (declare (fixnum n)) - (setf some t) - (wt-nl "ecl_bds_unwind1(cl_env_copy);"))) - (t - (setf some t) - (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))) + (dotimes (n bds-bind) + (declare (fixnum n)) + (setf some t) + (wt-nl "ecl_bds_unwind1(cl_env_copy);"))) + (t + (setf some t) + (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))) (case ihs-p (IHS (setf some t) @@ -72,89 +72,89 @@ (dolist (ue *unwind-exit* (baboon-improper-*exit*)) ;; perform all unwind-exit's which precede *exit* (cond - ((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n) + ((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n) (cond ((eq (car ue) 'STACK) - (setf stack-frame (second ue))) - ((eq (car ue) 'LCL) - (setq bds-lcl ue bds-bind 0)) - ((eq ue *exit*) - ;; all body forms except the last (returning) are dealt here - (cond ((and (consp *destination*) - (or (eq (car *destination*) 'JUMP-TRUE) - (eq (car *destination*) 'JUMP-FALSE))) - (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) - ((not (or bds-lcl (plusp bds-bind) stack-frame)) - (set-loc loc)) - ;; Save the value if LOC may possibly refer - ;; to special binding. - ((or (loc-refers-to-special loc) - (loc-refers-to-special *destination*)) - (let* ((*temp* *temp*) - (temp (make-temp-var))) - (let ((*destination* temp)) - (set-loc loc)) ; temp <- loc - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (set-loc temp))) ; *destination* <- temp - (t - (set-loc loc) - (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) - (when jump-p (wt-nl) (wt-go *exit*)) - (return)) - (t (setq jump-p t)))) + (setf stack-frame (second ue))) + ((eq (car ue) 'LCL) + (setq bds-lcl ue bds-bind 0)) + ((eq ue *exit*) + ;; all body forms except the last (returning) are dealt here + (cond ((and (consp *destination*) + (or (eq (car *destination*) 'JUMP-TRUE) + (eq (car *destination*) 'JUMP-FALSE))) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) + ((not (or bds-lcl (plusp bds-bind) stack-frame)) + (set-loc loc)) + ;; Save the value if LOC may possibly refer + ;; to special binding. + ((or (loc-refers-to-special loc) + (loc-refers-to-special *destination*)) + (let* ((*temp* *temp*) + (temp (make-temp-var))) + (let ((*destination* temp)) + (set-loc loc)) ; temp <- loc + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (set-loc temp))) ; *destination* <- temp + (t + (set-loc loc) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) + (when jump-p (wt-nl) (wt-go *exit*)) + (return)) + (t (setq jump-p t)))) ((numberp ue) (baboon-unwind-exit ue) (setq bds-lcl ue bds-bind 0)) (t (case ue - (IHS (setf ihs-p ue)) + (IHS (setf ihs-p ue)) (IHS-ENV (setf ihs-p (or ihs-p ue))) - (BDS-BIND (incf bds-bind)) - (RETURN - (unless (eq *exit* 'RETURN) (baboon-unwind-exit ue)) - ;; *destination* must be either RETURN or TRASH. - (cond ((eq loc 'VALUES) - ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (wt-nl "return cl_env_copy->values[0];")) - ((eq loc 'RETURN) - ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (wt-nl "return value0;")) - (t - (let* ((*destination* 'RETURN)) - (set-loc loc)) - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (wt-nl "return value0;"))) - (return)) - ((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT - RETURN-SINGLE-FLOAT RETURN-OBJECT) - (when (eq *exit* ue) - ;; *destination* must be RETURN-FIXNUM - (setq loc (list 'COERCE-LOC - (getf '(RETURN-FIXNUM :fixnum - RETURN-CHARACTER :char - RETURN-SINGLE-FLOAT :float - RETURN-DOUBLE-FLOAT :double - RETURN-OBJECT :object) - ue) - loc)) - (if (or bds-lcl (plusp bds-bind)) - (let ((lcl (make-lcl-var :type (second loc)))) - (wt-nl-open-brace) - (wt-nl "cl_fixnum " lcl "= " loc ";") - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (wt-nl "return(" lcl ");") - (wt-nl-close-brace)) - (progn - (wt-nl "return(" loc ");"))) - (return))) - (FRAME - (let ((*destination* (tmp-destination *destination*))) - (set-loc loc) - (setq loc *destination*)) - (wt-nl "ecl_frs_pop(cl_env_copy);")) - (TAIL-RECURSION-MARK) - (JUMP (setq jump-p t)) - (t (baboon-unwind-exit ue)))))) + (BDS-BIND (incf bds-bind)) + (RETURN + (unless (eq *exit* 'RETURN) (baboon-unwind-exit ue)) + ;; *destination* must be either RETURN or TRASH. + (cond ((eq loc 'VALUES) + ;; from multiple-value-prog1 or values + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return cl_env_copy->values[0];")) + ((eq loc 'RETURN) + ;; from multiple-value-prog1 or values + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return value0;")) + (t + (let* ((*destination* 'RETURN)) + (set-loc loc)) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return value0;"))) + (return)) + ((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT + RETURN-SINGLE-FLOAT RETURN-OBJECT) + (when (eq *exit* ue) + ;; *destination* must be RETURN-FIXNUM + (setq loc (list 'COERCE-LOC + (getf '(RETURN-FIXNUM :fixnum + RETURN-CHARACTER :char + RETURN-SINGLE-FLOAT :float + RETURN-DOUBLE-FLOAT :double + RETURN-OBJECT :object) + ue) + loc)) + (if (or bds-lcl (plusp bds-bind)) + (let ((lcl (make-lcl-var :type (second loc)))) + (wt-nl-open-brace) + (wt-nl "cl_fixnum " lcl "= " loc ";") + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return(" lcl ");") + (wt-nl-close-brace)) + (progn + (wt-nl "return(" loc ");"))) + (return))) + (FRAME + (let ((*destination* (tmp-destination *destination*))) + (set-loc loc) + (setq loc *destination*)) + (wt-nl "ecl_frs_pop(cl_env_copy);")) + (TAIL-RECURSION-MARK) + (JUMP (setq jump-p t)) + (t (baboon-unwind-exit ue)))))) ;;; Never reached ) @@ -175,41 +175,41 @@ for ue = (car unwind-exit) until (eq unwind-exit last-cons) do (cond - ((consp ue) - (when (eq (first ue) 'STACK) - (setf stack-frame (second ue)))) - ((numberp ue) - (setq bds-lcl ue bds-bind 0)) - ((eq ue 'BDS-BIND) - (incf bds-bind)) - ((eq ue 'FRAME) - (wt-nl "ecl_frs_pop(cl_env_copy);")) - ((eq ue 'JUMP)) - ((eq ue 'IHS-ENV) - (setf ihs-p ue)) - (t (baboon-unwind-exit ue))) + ((consp ue) + (when (eq (first ue) 'STACK) + (setf stack-frame (second ue)))) + ((numberp ue) + (setq bds-lcl ue bds-bind 0)) + ((eq ue 'BDS-BIND) + (incf bds-bind)) + ((eq ue 'FRAME) + (wt-nl "ecl_frs_pop(cl_env_copy);")) + ((eq ue 'JUMP)) + ((eq ue 'IHS-ENV) + (setf ihs-p ue)) + (t (baboon-unwind-exit ue))) finally (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p)))) (defun unwind-no-exit (exit) (let ((where (member exit *unwind-exit* :test #'eq))) (unless where (baboon :format-control "Unwind-exit label ~A not found" - :format-arguments (list exit))) + :format-arguments (list exit))) (unwind-no-exit-until where))) ;;; Tail-recursion optimization for a function F is possible only if -;;; 1. F receives only required parameters, and -;;; 2. no required parameter of F is enclosed in a closure. +;;; 1. F receives only required parameters, and +;;; 2. no required parameter of F is enclosed in a closure. ;;; ;;; A recursive call (F e1 ... en) may be replaced by a loop only if -;;; 1. F is not declared as NOTINLINE, -;;; 2. n is equal to the number of required parameters of F, -;;; 3. the form is a normal function call (i.e. args are not ARGS-PUSHED), -;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic -;;; binding (such as LET, LET*, PROGV), -;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame -;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are -;;; enclosed in a closure, and CATCH), +;;; 1. F is not declared as NOTINLINE, +;;; 2. n is equal to the number of required parameters of F, +;;; 3. the form is a normal function call (i.e. args are not ARGS-PUSHED), +;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic +;;; binding (such as LET, LET*, PROGV), +;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame +;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are +;;; enclosed in a closure, and CATCH), (defun tail-recursion-possible () (dolist (ue *unwind-exit* (baboon)) @@ -221,16 +221,16 @@ (defun c2try-tail-recursive-call (fun args) (when (and *tail-recursion-info* - (eq fun (first *tail-recursion-info*)) - (last-call-p) - (tail-recursion-possible) - (inline-possible (fun-name fun)) - (= (length args) (length (rest *tail-recursion-info*)))) + (eq fun (first *tail-recursion-info*)) + (last-call-p) + (tail-recursion-possible) + (inline-possible (fun-name fun)) + (= (length args) (length (rest *tail-recursion-info*)))) (let* ((*destination* 'TRASH) - (*exit* (next-label)) - (*unwind-exit* (cons *exit* *unwind-exit*))) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) (c2psetq nil ;; We do not provide any C2FORM - (cdr *tail-recursion-info*) args) + (cdr *tail-recursion-info*) args) (wt-label *exit*)) (unwind-no-exit 'TAIL-RECURSION-MARK) (wt-nl "goto TTL;") diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index f74a3f030..f5f4c2587 100755 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -29,9 +29,9 @@ (defun rep-type->lisp-type (name) (let ((output (rep-type-record-unsafe name))) (cond (output - (rep-type-lisp-type output)) - ((lisp-type-p name) name) - (t (error "Unknown representation type ~S" name))))) + (rep-type-lisp-type output)) + ((lisp-type-p name) name) + (t (error "Unknown representation type ~S" name))))) (defun lisp-type->rep-type (type) (cond @@ -44,7 +44,7 @@ ;; Find the most specific type that fits (dolist (record (machine-sorted-types *machine*) :object) (when (subtypep type (rep-type-lisp-type record)) - (return-from lisp-type->rep-type (rep-type-name record))))))) + (return-from lisp-type->rep-type (rep-type-name record))))))) (defun c-number-rep-type-p (rep-type) (let ((r (rep-type-record-unsafe rep-type))) @@ -75,9 +75,9 @@ (defun wt-to-object-conversion (loc-rep-type loc) (when (and (consp loc) (member (first loc) - '(single-float-value - double-float-value - long-float-value))) + '(single-float-value + double-float-value + long-float-value))) (wt (third loc)) ;; VV index (return-from wt-to-object-conversion)) (let ((record (rep-type-record loc-rep-type))) @@ -87,14 +87,14 @@ (defun wt-from-object-conversion (dest-type loc-type rep-type loc) (let* ((record (rep-type-record rep-type)) - (coercer (and record (rep-type-from-lisp record)))) + (coercer (and record (rep-type-from-lisp record)))) (unless coercer (cmperr "Cannot coerce lisp object to C type ~A" rep-type)) (wt (if (or (policy-assume-no-errors) (subtypep loc-type dest-type)) - (rep-type-from-lisp-unsafe record) - coercer) - "(" loc ")"))) + (rep-type-from-lisp-unsafe record) + coercer) + "(" loc ")"))) ;; ---------------------------------------------------------------------- ;; LOCATIONS and representation types @@ -108,132 +108,132 @@ (if (atom loc) t (case (first loc) - ((CALL CALL-LOCAL) NIL) - ((C-INLINE) (not (fifth loc))) ; side effects? - (otherwise t)))) + ((CALL CALL-LOCAL) NIL) + ((C-INLINE) (not (fifth loc))) ; side effects? + (otherwise t)))) (defun loc-type (loc) (cond ((eq loc NIL) 'NULL) - ((var-p loc) (var-type loc)) + ((var-p loc) (var-type loc)) ((vv-p loc) (vv-type loc)) - ((numberp loc) (lisp-type->rep-type (type-of loc))) - ((atom loc) 'T) - (t - (case (first loc) - (FIXNUM-VALUE 'FIXNUM) - (CHARACTER-VALUE (type-of (code-char (second loc)))) - (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) - (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) - (LONG-FLOAT-VALUE 'LONG-FLOAT) - (C-INLINE (let ((type (first (second loc)))) + ((numberp loc) (lisp-type->rep-type (type-of loc))) + ((atom loc) 'T) + (t + (case (first loc) + (FIXNUM-VALUE 'FIXNUM) + (CHARACTER-VALUE (type-of (code-char (second loc)))) + (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) + (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) + (LONG-FLOAT-VALUE 'LONG-FLOAT) + (C-INLINE (let ((type (first (second loc)))) (cond ((and (consp type) (eq (first type) 'VALUES)) T) ((lisp-type-p type) type) (t (rep-type->lisp-type type))))) - (BIND (var-type (second loc))) - (LCL (or (third loc) T)) - (THE (second loc)) - (CALL-NORMAL (fourth loc)) - (otherwise T))))) + (BIND (var-type (second loc))) + (LCL (or (third loc) T)) + (THE (second loc)) + (CALL-NORMAL (fourth loc)) + (otherwise T))))) (defun loc-representation-type (loc) (cond ((member loc '(NIL T)) :object) - ((var-p loc) (var-rep-type loc)) + ((var-p loc) (var-rep-type loc)) ((vv-p loc) :object) - ((numberp loc) (lisp-type->rep-type (type-of loc))) + ((numberp loc) (lisp-type->rep-type (type-of loc))) ((eq loc 'TRASH) :void) - ((atom loc) :object) - (t - (case (first loc) - (FIXNUM-VALUE :fixnum) - (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) - (DOUBLE-FLOAT-VALUE :double) - (SINGLE-FLOAT-VALUE :float) - (LONG-FLOAT-VALUE :long-double) - (C-INLINE (let ((type (first (second loc)))) + ((atom loc) :object) + (t + (case (first loc) + (FIXNUM-VALUE :fixnum) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) + (DOUBLE-FLOAT-VALUE :double) + (SINGLE-FLOAT-VALUE :float) + (LONG-FLOAT-VALUE :long-double) + (C-INLINE (let ((type (first (second loc)))) (cond ((and (consp type) (eq (first type) 'VALUES)) :object) ((lisp-type-p type) (lisp-type->rep-type type)) (t type)))) - (BIND (var-rep-type (second loc))) - (LCL (lisp-type->rep-type (or (third loc) T))) + (BIND (var-rep-type (second loc))) + (LCL (lisp-type->rep-type (or (third loc) T))) ((JUMP-TRUE JUMP-FALSE) :bool) - (THE (loc-representation-type (third loc))) - (otherwise :object))))) + (THE (loc-representation-type (third loc))) + (otherwise :object))))) (defun wt-coerce-loc (dest-rep-type loc) (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) ;(print dest-rep-type) ;(print loc) (let* ((dest-type (rep-type->lisp-type dest-rep-type)) - (loc-type (loc-type loc)) - (loc-rep-type (loc-representation-type loc))) + (loc-type (loc-type loc)) + (loc-rep-type (loc-representation-type loc))) (labels ((coercion-error () - (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~ - to C/C++ type (~S,~S)" + (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~ + to C/C++ type (~S,~S)" loc-type loc-rep-type dest-type dest-rep-type)) - (ensure-valid-object-type (a-lisp-type) - (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) - (coercion-error)))) + (ensure-valid-object-type (a-lisp-type) + (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) + (coercion-error)))) (when (eq dest-rep-type loc-rep-type) - (wt loc) - (return-from wt-coerce-loc)) + (wt loc) + (return-from wt-coerce-loc)) (case dest-rep-type - ((:char :unsigned-char :wchar) - (case loc-rep-type - ((:char :unsigned-char :wchar) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((:object) - (ensure-valid-object-type dest-type) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (otherwise - (coercion-error)))) - ((:float :double :long-double) - (cond - ((c-number-rep-type-p loc-rep-type) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((eq loc-rep-type :object) - ;; We relax the check a bit, because it is valid in C to coerce - ;; between floats of different types. - (ensure-valid-object-type 'FLOAT) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (t - (coercion-error)))) - ((:bool) - (cond - ((c-number-rep-type-p loc-rep-type) - (wt "1")) - ((eq loc-rep-type :object) - (wt "(" loc ")!=ECL_NIL")) - (t - (coercion-error)))) - ((:object) - (case loc-rep-type - ((:int-sse-pack :float-sse-pack :double-sse-pack) + ((:char :unsigned-char :wchar) + (case loc-rep-type + ((:char :unsigned-char :wchar) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (otherwise + (coercion-error)))) + ((:float :double :long-double) + (cond + ((c-number-rep-type-p loc-rep-type) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((eq loc-rep-type :object) + ;; We relax the check a bit, because it is valid in C to coerce + ;; between floats of different types. + (ensure-valid-object-type 'FLOAT) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (t + (coercion-error)))) + ((:bool) + (cond + ((c-number-rep-type-p loc-rep-type) + (wt "1")) + ((eq loc-rep-type :object) + (wt "(" loc ")!=ECL_NIL")) + (t + (coercion-error)))) + ((:object) + (case loc-rep-type + ((:int-sse-pack :float-sse-pack :double-sse-pack) (when (>= (cmp-env-optimization 'speed) 1) (cmpwarn-style "Boxing a value of type ~S - performance degraded." loc-rep-type)))) - (wt-to-object-conversion loc-rep-type loc)) - ((:pointer-void) - (case loc-rep-type - ((:object) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - ((:cstring) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) - ((:cstring) - (coercion-error)) - ((:char*) - (case loc-rep-type - ((:object) - (wt "ecl_base_string_pointer_safe(" loc ")")) - ((:pointer-void) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) - ((:int-sse-pack :float-sse-pack :double-sse-pack) - (case loc-rep-type - ((:object) - (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc)) + (wt-to-object-conversion loc-rep-type loc)) + ((:pointer-void) + (case loc-rep-type + ((:object) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + ((:cstring) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:cstring) + (coercion-error)) + ((:char*) + (case loc-rep-type + ((:object) + (wt "ecl_base_string_pointer_safe(" loc ")")) + ((:pointer-void) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:int-sse-pack :float-sse-pack :double-sse-pack) + (case loc-rep-type + ((:object) + (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc)) ;; Implicitly cast between SSE subtypes ((:int-sse-pack :float-sse-pack :double-sse-pack) (wt (ecase dest-rep-type @@ -247,20 +247,20 @@ (:int-sse-pack "_mm_castsi128_pd") (:float-sse-pack "_mm_castps_pd")))) "(" loc ")")) - (otherwise - (coercion-error)))) - (t - ;; At this point we only have coercions to integers - (cond - ((not (c-integer-rep-type-p dest-rep-type)) - (coercion-error)) - ((c-number-rep-type-p loc-rep-type) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((eq :object loc-rep-type) - (ensure-valid-object-type dest-type) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (t - (coercion-error)))))))) + (otherwise + (coercion-error)))) + (t + ;; At this point we only have coercions to integers + (cond + ((not (c-integer-rep-type-p dest-rep-type)) + (coercion-error)) + ((c-number-rep-type-p loc-rep-type) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((eq :object loc-rep-type) + (ensure-valid-object-type dest-type) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (t + (coercion-error)))))))) ;;; ---------------------------------------------------------------------- ;;; C/C++ DECLARATIONS AND HEADERS @@ -305,80 +305,80 @@ (defun c1c-inline (args) ;; We are on the safe side by assuming that the form has side effects (destructuring-bind (arguments arg-types output-type c-expression - &rest rest - &key (side-effects t) one-liner - &aux output-rep-type) + &rest rest + &key (side-effects t) one-liner + &aux output-rep-type) args (unless (= (length arguments) (length arg-types)) (cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S" - `(C-INLINE ,@args))) + `(C-INLINE ,@args))) ;; We cannot handle :cstrings as input arguments. :cstrings are ;; null-terminated strings, but not all of our lisp strings will ;; be null terminated. In particular, those with a fill pointer ;; will not. (let ((ndx (position :cstring arg-types))) (when ndx - (let* ((var (gensym)) + (let* ((var (gensym)) (arguments (copy-list arguments)) - (value (elt arguments ndx))) - (setf (elt arguments ndx) var - (elt arg-types ndx) :char*) - (return-from c1c-inline - (c1expr - `(ffi::with-cstring (,var ,value) - (c-inline ,arguments ,arg-types ,output-type ,c-expression - ,@rest))))))) + (value (elt arguments ndx))) + (setf (elt arguments ndx) var + (elt arg-types ndx) :char*) + (return-from c1c-inline + (c1expr + `(ffi::with-cstring (,var ,value) + (c-inline ,arguments ,arg-types ,output-type ,c-expression + ,@rest))))))) ;; Find out the output types of the inline form. The syntax is rather relaxed - ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) + ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) (flet ((produce-type-pair (type) - (if (lisp-type-p type) - (cons type (lisp-type->rep-type type)) - (cons (rep-type->lisp-type type) type)))) + (if (lisp-type-p type) + (cons type (lisp-type->rep-type type)) + (cons (rep-type->lisp-type type) type)))) (cond ((eq output-type ':void) - (setf output-rep-type '() - output-type 'NIL)) - ((equal output-type '(VALUES &REST t)) - (setf output-rep-type '((VALUES &REST t)))) - ((and (consp output-type) (eql (first output-type) 'VALUES)) - (let ((x (mapcar #'produce-type-pair (rest output-type)))) - (setf output-rep-type (mapcar #'cdr x) - output-type `(VALUES ,@(mapcar #'car x))))) - (t - (let ((x (produce-type-pair output-type))) - (setf output-type (car x) - output-rep-type (list (cdr x))))))) + (setf output-rep-type '() + output-type 'NIL)) + ((equal output-type '(VALUES &REST t)) + (setf output-rep-type '((VALUES &REST t)))) + ((and (consp output-type) (eql (first output-type) 'VALUES)) + (let ((x (mapcar #'produce-type-pair (rest output-type)))) + (setf output-rep-type (mapcar #'cdr x) + output-type `(VALUES ,@(mapcar #'car x))))) + (t + (let ((x (produce-type-pair output-type))) + (setf output-type (car x) + output-rep-type (list (cdr x))))))) (unless (and (listp arguments) - (listp arg-types) - (stringp c-expression)) + (listp arg-types) + (stringp c-expression)) (cmperr "C-INLINE: syntax error in ~S" - (list* 'c-inline args))) + (list* 'c-inline args))) (unless (= (length arguments) - (length arg-types)) + (length arg-types)) (cmperr "C-INLINE: wrong number of arguments in ~S" - (list* 'c-inline args))) + (list* 'c-inline args))) (let* ((arguments (mapcar #'c1expr arguments)) - (form (make-c1form* 'C-INLINE :type output-type - :side-effects side-effects - :args arguments arg-types - output-rep-type - c-expression - side-effects - one-liner))) + (form (make-c1form* 'C-INLINE :type output-type + :side-effects side-effects + :args arguments arg-types + output-rep-type + c-expression + side-effects + one-liner))) (loop for form in arguments - when (eq (c1form-name form) 'VAR) - do (let ((var (c1form-arg 0 form))) - (add-to-set-nodes var form))) + when (eq (c1form-name form) 'VAR) + do (let ((var (c1form-arg 0 form))) + (add-to-set-nodes var form))) form))) (defun c1c-progn (arguments) (let* ((variables (mapcar #'c1vref (pop arguments))) - (statements (loop for form in arguments - collect (if (stringp form) - form - (c1expr form)))) - (form (make-c1form* 'FFI:C-PROGN :type NIL - :side-effects t - :args variables statements))) + (statements (loop for form in arguments + collect (if (stringp form) + form + (c1expr form)))) + (form (make-c1form* 'FFI:C-PROGN :type NIL + :side-effects t + :args variables statements))) (add-to-set-nodes-of-var-list variables form) form)) @@ -386,34 +386,34 @@ (loop with *destination* = 'TRASH for form in statements do (cond ((stringp form) - (wt-nl) - (wt-c-inline-loc :void form variables - t ; side effects - nil) ; no output variables - ) - (t - (c2expr* form))) + (wt-nl) + (wt-c-inline-loc :void form variables + t ; side effects + nil) ; no output variables + ) + (t + (c2expr* form))) finally (unwind-exit nil))) (defun produce-inline-loc (inlined-arguments arg-types output-rep-type - c-expression side-effects one-liner) + c-expression side-effects one-liner) (let* (args-to-be-saved - coerced-arguments) + coerced-arguments) ;; If the expression begins with @[0-9a-z]*, this means we are ;; saving some variables. (when (and (> (length c-expression) 1) - (eq (char c-expression 0) #\@)) + (eq (char c-expression 0) #\@)) (do ((ndx 1 (1+ ndx))) - ((>= ndx (length c-expression))) - (let ((c (char c-expression ndx))) - (when (eq c #\;) - (setf c-expression (subseq c-expression (1+ ndx))) - (return)) - (unless (alphanumericp c) - (setf args-to-be-saved nil) - (return)) - (push (- (char-code c) (char-code #\0)) - args-to-be-saved)))) + ((>= ndx (length c-expression))) + (let ((c (char c-expression ndx))) + (when (eq c #\;) + (setf c-expression (subseq c-expression (1+ ndx))) + (return)) + (unless (alphanumericp c) + (setf args-to-be-saved nil) + (return)) + (push (- (char-code c) (char-code #\0)) + args-to-be-saved)))) (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved)) ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) @@ -422,18 +422,18 @@ ;; effects, try to omit it. (when (null output-rep-type) (if side-effects - (progn - (wt-nl) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) - (when one-liner (wt ";"))) - (cmpnote "Ignoring form ~S" c-expression)) + (progn + (wt-nl) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) + (when one-liner (wt ";"))) + (cmpnote "Ignoring form ~S" c-expression)) (return-from produce-inline-loc NIL)) ;; If the form is a one-liner, we can simply propagate this expression until the ;; place where the value is used. (when one-liner (return-from produce-inline-loc - `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects + `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects ,(if (equalp output-rep-type '((VALUES &REST T))) 'VALUES NIL)))) @@ -446,20 +446,20 @@ ;; Otherwise we have to set up variables for holding the output. (flet ((make-output-var (type) - (let ((var (make-lcl-var :rep-type type))) - (wt-nl (rep-type->c-name type) " " var ";") - var))) + (let ((var (make-lcl-var :rep-type type))) + (wt-nl (rep-type->c-name type) " " var ";") + var))) (open-inline-block) (let ((output-vars (mapcar #'make-output-var output-rep-type))) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) - (cond ((= (length output-vars) 1) - (first output-vars)) - (t - (loop for v in output-vars - for i from 0 - do (let ((*destination* `(VALUE ,i))) (set-loc v))) - (wt "cl_env_copy->nvalues=" (length output-vars) ";") - 'VALUES)))))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) + (cond ((= (length output-vars) 1) + (first output-vars)) + (t + (loop for v in output-vars + for i from 0 + do (let ((*destination* `(VALUE ,i))) (set-loc v))) + (wt "cl_env_copy->nvalues=" (length output-vars) ";") + 'VALUES)))))) (defun c2c-inline (c1form arguments &rest rest) (declare (ignore c1form)) @@ -474,8 +474,8 @@ ;; C-INLINE, instructing that the value should be saved in a temporary ;; variable. Finally, TYPES is a list of destination types, to which ;; the former values are coerced. The destination types can be - ;; - A lisp type (:OBJECT, :FINXUM, etc) - ;; - A machine representation type (T, INTEGER, etc) + ;; - A lisp type (:OBJECT, :FINXUM, etc) + ;; - A machine representation type (T, INTEGER, etc) (loop with block-opened = nil for (lisp-type loc) in inlined-args for type in (or types '#1=(:object . #1#)) @@ -483,59 +483,59 @@ for rep-type = (lisp-type->rep-type type) collect (cond ((and args-to-be-saved - (member i args-to-be-saved :test #'eql) - (not (loc-movable-p loc))) - (let ((lcl (make-lcl-var :rep-type rep-type))) - (wt-nl) - (unless block-opened - (setf block-opened t) - (open-inline-block)) - (wt (rep-type->c-name rep-type) " " lcl "= ") - (wt-coerce-loc rep-type loc) - (wt ";") - lcl)) - ((equal rep-type (loc-representation-type loc)) - loc) - (t - `(COERCE-LOC ,rep-type ,loc))))) + (member i args-to-be-saved :test #'eql) + (not (loc-movable-p loc))) + (let ((lcl (make-lcl-var :rep-type rep-type))) + (wt-nl) + (unless block-opened + (setf block-opened t) + (open-inline-block)) + (wt (rep-type->c-name rep-type) " " lcl "= ") + (wt-coerce-loc rep-type loc) + (wt ";") + lcl)) + ((equal rep-type (loc-representation-type loc)) + loc) + (t + `(COERCE-LOC ,rep-type ,loc))))) (defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) (with-input-from-string (s c-expression) (when (and output-vars (not (eq output-vars 'VALUES))) (wt-nl)) (do ((c (read-char s nil nil) - (read-char s nil nil))) - ((null c)) + (read-char s nil nil))) + ((null c)) (case c - (#\@ - (let ((object (read s))) - (cond ((and (consp object) (equal (first object) 'RETURN)) - (if (eq output-vars 'VALUES) - (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") - (let ((ndx (or (second object) 0)) - (l (length output-vars))) - (if (< ndx l) - (wt (nth ndx output-vars)) - (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" - ndx l))))) - (t - (when (and (consp object) (eq (first object) 'QUOTE)) - (setq object (second object))) - (wt (add-object object :permanent t)))))) - (#\# - (let* ((k (read-char s)) - (next-char (peek-char nil s nil nil)) - (index (digit-char-p k 36))) - (cond ((eq k #\#) + (#\@ + (let ((object (read s))) + (cond ((and (consp object) (equal (first object) 'RETURN)) + (if (eq output-vars 'VALUES) + (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" + ndx l))))) + (t + (when (and (consp object) (eq (first object) 'QUOTE)) + (setq object (second object))) + (wt (add-object object :permanent t)))))) + (#\# + (let* ((k (read-char s)) + (next-char (peek-char nil s nil nil)) + (index (digit-char-p k 36))) + (cond ((eq k #\#) (wt #\#)) ((or (null index) (and next-char (alphanumericp next-char))) - (wt #\# k)) - ((< index (length coerced-arguments)) - (wt (nth index coerced-arguments))) - (t - (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) - (otherwise - (write-char c *compiler-output1*)))))) + (wt #\# k)) + ((< index (length coerced-arguments)) + (wt (nth index coerced-arguments))) + (t + (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) + (otherwise + (write-char c *compiler-output1*)))))) (defun c-inline-safe-string (constant-string) ;; Produce a text representation of a string that can be used @@ -543,7 +543,7 @@ ;; characters (c-filtered-string (concatenate 'string - (loop for c across constant-string - when (member c '(#\# #\@)) - collect c - collect c)))) + (loop for c across constant-string + when (member c '(#\# #\@)) + collect c + collect c)))) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 3fe1dfee2..7ed0a9363 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -21,59 +21,59 @@ (defun c1labels/flet (origin args) (check-args-number origin args 1) (let ((new-env (cmp-env-copy)) - (defs '()) - (local-funs '()) - (fnames '()) - body-c1form) + (defs '()) + (local-funs '()) + (fnames '()) + body-c1form) ;; On a first round, we extract the definitions of the functions, ;; and build empty function objects that record the references to ;; this functions in the processed body. In the end - ;; DEFS = ( { ( fun-object function-body ) }* ). + ;; DEFS = ( { ( fun-object function-body ) }* ). (dolist (def (car args)) (cmpck (or (endp def) - (not (si::valid-function-name-p (car def))) - (endp (cdr def))) - "The local function definition ~s is illegal." def) + (not (si::valid-function-name-p (car def))) + (endp (cdr def))) + "The local function definition ~s is illegal." def) (cmpck (member (car def) fnames) - "The function ~s was already defined." (car def)) + "The function ~s was already defined." (car def)) (push (car def) fnames) (let* ((name (car def)) - (var (make-var :name name :kind :object)) - (fun (make-fun :name name :var var))) - (cmp-env-register-function fun new-env) - (push (cons fun (cdr def)) defs))) + (var (make-var :name name :kind :object)) + (fun (make-fun :name name :var var))) + (cmp-env-register-function fun new-env) + (push (cons fun (cdr def)) defs))) ;; Now we compile the functions, either in an empty environment ;; in which there are no new functions (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env)))) (dolist (def (nreverse defs)) - (let ((fun (first def))) - ;; The closure type will be fixed later on by COMPUTE-... - (push (c1compile-function (rest def) :fun fun :CB/LB 'LB) - local-funs)))) + (let ((fun (first def))) + ;; The closure type will be fixed later on by COMPUTE-... + (push (c1compile-function (rest def) :fun fun :CB/LB 'LB) + local-funs)))) ;; When we are in a LABELs form, we have to propagate the external ;; variables from one function to the other functions that use it. (when (eq origin 'LABELS) (loop for change = nil - do (loop for f1 in local-funs - for vars = (fun-referenced-vars f1) - for funs = (fun-referenced-funs f1) - do (loop for f2 in (fun-referencing-funs f1) - for c1 = (add-to-fun-referenced-vars f2 vars) - for c2 = (add-to-fun-referenced-funs f2 funs) - for c3 = (update-fun-closure-type f2) - when (or c1 c2 c3) - do (setf change t))) - do (unless change (return)))) + do (loop for f1 in local-funs + for vars = (fun-referenced-vars f1) + for funs = (fun-referenced-funs f1) + do (loop for f2 in (fun-referencing-funs f1) + for c1 = (add-to-fun-referenced-vars f2 vars) + for c2 = (add-to-fun-referenced-funs f2 funs) + for c3 = (update-fun-closure-type f2) + when (or c1 c2 c3) + do (setf change t))) + do (unless change (return)))) ;; Now we can compile the body itself. (let ((*cmp-env* new-env)) (multiple-value-bind (body ss ts is other-decl) - (c1body (rest args) t) - (c1declare-specials ss) - (check-vdecl nil ts is) - (setq body-c1form (c1decl-body other-decl body)))) + (c1body (rest args) t) + (c1declare-specials ss) + (check-vdecl nil ts is) + (setq body-c1form (c1decl-body other-decl body)))) ;; Keep only functions that have been referenced at least once. ;; It is not possible to look at FUN-REF before because functions @@ -83,24 +83,24 @@ ;; Keep on inspecting the functions until the closure type does not ;; change. (loop while - (let ((x nil)) - (loop for f in local-funs - when (update-fun-closure-type f) - do (setf x t)) - x)) + (let ((x nil)) + (loop for f in local-funs + when (update-fun-closure-type f) + do (setf x t)) + x)) (if local-funs - (make-c1form* 'LOCALS :type (c1form-type body-c1form) - :args local-funs body-c1form (eq origin 'LABELS)) - body-c1form))) + (make-c1form* 'LOCALS :type (c1form-type body-c1form) + :args local-funs body-c1form (eq origin 'LABELS)) + body-c1form))) (defun child-function-p (presumed-parent fun) (declare (optimize speed)) (loop for real-parent = (fun-parent fun) while real-parent do (if (eq real-parent presumed-parent) - (return t) - (setf fun real-parent)))) + (return t) + (setf fun real-parent)))) (defun compute-closure-type (fun) (declare (si::c-local)) @@ -108,25 +108,25 @@ ;; it will have a full closure if it refers external non-global variables (dolist (var (fun-referenced-vars fun)) (cond ((global-var-p var)) - ;; ...across CB - ((ref-ref-ccb var) - (return-from compute-closure-type 'CLOSURE)) - (t - (setf lexical-closure-p t)))) + ;; ...across CB + ((ref-ref-ccb var) + (return-from compute-closure-type 'CLOSURE)) + (t + (setf lexical-closure-p t)))) ;; ...or if it directly calls a function (dolist (f (fun-referenced-funs fun)) (unless (child-function-p fun f) - ;; .. which has a full closure - (case (fun-closure f) - (CLOSURE (return-from compute-closure-type 'CLOSURE)) - (LEXICAL (setf lexical-closure-p t))))) + ;; .. which has a full closure + (case (fun-closure f) + (CLOSURE (return-from compute-closure-type 'CLOSURE)) + (LEXICAL (setf lexical-closure-p t))))) ;; ...or the function itself is referred across CB (when lexical-closure-p (if (or (fun-ref-ccb fun) - (and (fun-var fun) - (plusp (var-ref (fun-var fun))))) - 'CLOSURE - 'LEXICAL)))) + (and (fun-var fun) + (plusp (var-ref (fun-var fun))))) + 'CLOSURE + 'LEXICAL)))) (defun update-fun-closure-type-many (function-list) (do ((finish nil t) @@ -135,7 +135,7 @@ recompute) (dolist (f function-list) (when (update-fun-closure-type f) - (setf recompute t finish nil))))) + (setf recompute t finish nil))))) (defun prepend-new (l1 l2) (loop for f in l1 @@ -149,40 +149,40 @@ ;; This recursive algorithm is guaranteed to stop when functions ;; do not change. (let ((new-type (compute-closure-type fun)) - (to-be-updated (fun-child-funs fun))) + (to-be-updated (fun-child-funs fun))) ;; Same type (when (eq new-type old-type) - (return-from update-fun-closure-type nil)) + (return-from update-fun-closure-type nil)) (when (fun-global fun) - (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" - (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))) + (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))) (setf (fun-closure fun) new-type) ;; All external, non-global variables become of type closure (when (eq new-type 'CLOSURE) - (dolist (var (fun-referenced-vars fun)) - (unless (or (global-var-p var) - (eq (var-kind var) new-type)) - (setf (var-ref-clb var) nil - (var-ref-ccb var) t - (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT - to-be-updated - (prepend-new (var-functions-reading var) - (prepend-new (var-functions-setting var) - to-be-updated))))) - (dolist (f (fun-referenced-funs fun)) - (setf (fun-ref-ccb f) t))) + (dolist (var (fun-referenced-vars fun)) + (unless (or (global-var-p var) + (eq (var-kind var) new-type)) + (setf (var-ref-clb var) nil + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT + to-be-updated + (prepend-new (var-functions-reading var) + (prepend-new (var-functions-setting var) + to-be-updated))))) + (dolist (f (fun-referenced-funs fun)) + (setf (fun-ref-ccb f) t))) ;; If the status of some of the children changes, we have ;; to recompute the closure type. (when (update-fun-closure-type-many to-be-updated) - (update-fun-closure-type fun)) + (update-fun-closure-type fun)) t))) (defun c2locals (c1form funs body labels ;; labels is T when deriving from labels - &aux - (*env* *env*) - (*inline-blocks* 0) - (*env-lvl* *env-lvl*)) + &aux + (*env* *env*) + (*inline-blocks* 0) + (*env-lvl* *env-lvl*)) (declare (ignore c1form)) ;; create location for each function which is returned, ;; either in lexical: @@ -192,23 +192,23 @@ for var = (fun-var fun) when (plusp (var-ref var)) do (case (var-kind var) - ((lexical closure) - (push var closed-vars) - (unless env-grows - (setq env-grows (var-ref-ccb var)))) - (otherwise - (maybe-open-inline-block) - (bind (next-lcl) var) - (wt-nl "cl_object " *volatile* var ";"))) + ((lexical closure) + (push var closed-vars) + (unless env-grows + (setq env-grows (var-ref-ccb var)))) + (otherwise + (maybe-open-inline-block) + (bind (next-lcl) var) + (wt-nl "cl_object " *volatile* var ";"))) finally ;; if we have closed variables (when (env-grows env-grows) - (maybe-open-inline-block) - (let ((env-lvl *env-lvl*)) - (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";"))) + (maybe-open-inline-block) + (let ((env-lvl *env-lvl*)) + (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";"))) ;; bind closed locations because of possible circularities (loop for var in closed-vars - do (bind nil var))) + do (bind nil var))) ;; create the functions: (mapc #'new-local funs) ;; - then assign to it @@ -246,10 +246,10 @@ (check-args-number 'SYMBOL-MACROLET args 1) (let ((*cmp-env* (cmp-env-copy))) (dolist (def (car args)) - (let ((name (first def))) - (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) - "The symbol-macro definition ~s is illegal." def) - (cmp-env-register-symbol-macro name (second def)))) + (let ((name (first def))) + (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) + "The symbol-macro definition ~s is illegal." def) + (cmp-env-register-symbol-macro name (second def)))) (c1locally (cdr args)))) (defun local-function-ref (fname &optional build-object) @@ -257,35 +257,35 @@ (cmp-env-search-function fname) (when fun (when (functionp fun) - (when build-object - ;; Macro definition appears in #'.... This should not happen. - (cmperr "The name of a macro ~A was found in special form FUNCTION." fname)) - (return-from local-function-ref nil)) + (when build-object + ;; Macro definition appears in #'.... This should not happen. + (cmperr "The name of a macro ~A was found in special form FUNCTION." fname)) + (return-from local-function-ref nil)) (incf (fun-ref fun)) (if build-object - (setf (fun-ref-ccb fun) t) - (let ((caller *current-function*)) - (when (and caller - (not (member fun (fun-referenced-funs caller) :test #'eq))) - (push fun (fun-referenced-funs caller)) - (push caller (fun-referencing-funs fun))))) + (setf (fun-ref-ccb fun) t) + (let ((caller *current-function*)) + (when (and caller + (not (member fun (fun-referenced-funs caller) :test #'eq))) + (push fun (fun-referenced-funs caller)) + (push caller (fun-referencing-funs fun))))) ;; we introduce a variable to hold the funob (let ((var (fun-var fun))) - (cond (ccb (when build-object - (setf (var-ref-ccb var) t - (var-kind var) 'CLOSURE)) - (setf (fun-ref-ccb fun) t)) - (clb (when build-object - (setf (var-ref-clb var) t - (var-kind var) 'LEXICAL)))))) + (cond (ccb (when build-object + (setf (var-ref-ccb var) t + (var-kind var) 'CLOSURE)) + (setf (fun-ref-ccb fun) t)) + (clb (when build-object + (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL)))))) fun)) (defun c2call-local (c1form fun args) (declare (type fun fun) - (ignore c1form)) + (ignore c1form)) (unless (c2try-tail-recursive-call fun args) (let ((*inline-blocks* 0) (*temp* *temp*)) (unwind-exit (call-loc (fun-name fun) fun (inline-args args) - (c1form-primary-type c1form))) + (c1form-primary-type c1form))) (close-inline-blocks)))) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index a067c49c1..57f2d968a 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -17,11 +17,11 @@ ;;; ;;; ALL C1FORMS: Intermediate language used by the compiler ;;; -;;; body = (c1form*) -;;; tag-body = ({c1form | tag}*) -;;; return-type = {CLB | CCB | UNWIND-PROTECT} -;;; *value = c1form -;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) +;;; body = (c1form*) +;;; tag-body = ({c1form | tag}*) +;;; return-type = {CLB | CCB | UNWIND-PROTECT} +;;; *value = c1form +;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) ;;; (defun print-c1form (form stream) @@ -29,9 +29,9 @@ (defun make-c1form (name subform &rest args) (let ((form (do-make-c1form :name name :args args - :type (info-type subform) - :sp-change (info-sp-change subform) - :volatile (info-volatile subform) + :type (info-type subform) + :sp-change (info-sp-change subform) + :volatile (info-volatile subform) :form *current-form* :toplevel-form *current-toplevel-form* :file *compile-file-truename* @@ -41,24 +41,24 @@ (defun make-c1form* (name &rest args) (let ((info-args '()) - (form-args '())) + (form-args '())) (do ((l args (cdr l))) - ((endp l)) + ((endp l)) (let ((key (first l))) - (cond ((not (keywordp key)) - (baboon)) - ((eq key ':args) - (setf form-args (rest l)) - (return)) - (t - (setf info-args (list* key (second l) info-args) - l (cdr l)))))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) (let ((form (apply #'do-make-c1form :name name :args form-args :form *current-form* :toplevel-form *current-toplevel-form* :file *compile-file-truename* :file-position *compile-file-position* - info-args))) + info-args))) (c1form-add-info form form-args) form))) @@ -118,10 +118,10 @@ (defun find-form-in-node-list (form list) (let ((v1 (loop with form-parents = (c1form-parents form) - for presumed-child-parents in list - thereis (tailp form-parents presumed-child-parents))) - (v2 (loop for presumed-child-parents in list - thereis (member form presumed-child-parents :test #'eq)))) + for presumed-child-parents in list + thereis (tailp form-parents presumed-child-parents))) + (v2 (loop for presumed-child-parents in list + thereis (member form presumed-child-parents :test #'eq)))) (unless (eq (and v1 t) (and v2 t)) (baboon :format-control "Mismatch between FIND-FORM-IN-NODE-LISTs")) v1)) @@ -133,7 +133,7 @@ (let ((parents (c1form-parents form))) (unless (member parents list) (baboon :format-control "Unable to find C1FORM~%~4I~A~%in node list~%~4I~A" - :format-arguments (list form list))) + :format-arguments (list form list))) (delete parents list))) (defun traverse-c1form-tree (tree function) @@ -195,11 +195,11 @@ (defun relocate-parents-list (dest new-fields) (let* ((old (c1form-parents dest)) - (first-cons (or (c1form-parents new-fields) old))) + (first-cons (or (c1form-parents new-fields) old))) (setf (car first-cons) dest - (cdr first-cons) (rest old) - (c1form-parents new-fields) nil - (c1form-parents dest) first-cons))) + (cdr first-cons) (rest old) + (c1form-parents new-fields) nil + (c1form-parents dest) first-cons))) (defun c1form-replace-with (dest new-fields) ;; Side effects might have to be propagated to the parents @@ -220,7 +220,7 @@ ;; If this is the first time we replace a reference with this one ;; then we have to remove it from the read nodes of the variable (when (c1form-parents new-fields) - (delete-from-read-nodes var new-fields)) + (delete-from-read-nodes var new-fields)) ;; ... and then add the new node (relocate-parents-list dest new-fields) (add-to-read-nodes var dest))) @@ -228,27 +228,27 @@ (relocate-parents-list dest new-fields))) ;; Remaining flags are just copied (setf (c1form-name dest) (c1form-name new-fields) - (c1form-local-vars dest) (c1form-local-vars new-fields) + (c1form-local-vars dest) (c1form-local-vars new-fields) (c1form-type dest) (values-type-and (c1form-type new-fields) - (c1form-type dest)) + (c1form-type dest)) (c1form-sp-change dest) (c1form-sp-change new-fields) (c1form-side-effects dest) (c1form-side-effects new-fields) (c1form-volatile dest) (c1form-volatile new-fields) (c1form-args dest) (c1form-args new-fields) - (c1form-env dest) (c1form-env new-fields) - (c1form-form dest) (c1form-form new-fields) - (c1form-toplevel-form dest) (c1form-toplevel-form new-fields) - (c1form-file dest) (c1form-file new-fields) - (c1form-file-position dest) (c1form-file-position new-fields))) + (c1form-env dest) (c1form-env new-fields) + (c1form-form dest) (c1form-form new-fields) + (c1form-toplevel-form dest) (c1form-toplevel-form new-fields) + (c1form-file dest) (c1form-file new-fields) + (c1form-file-position dest) (c1form-file-position new-fields))) ;; should check whether a form before var causes a side-effect ;; exactly one occurrence of var is present in forms (defun delete-c1forms (form) (flet ((eliminate-references (form) (when (eq (c1form-name form) 'VAR) - (let ((var (c1form-arg 0 form))) - (when var - (delete-from-read-nodes var form)))))) + (let ((var (c1form-arg 0 form))) + (when var + (delete-from-read-nodes var form)))))) (traverse-c1form-tree form #'eliminate-references))) (defun c1form-constant-p (form) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index b9cf533b5..ffd191aff 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -18,32 +18,32 @@ (defun c1apply (args) (check-args-number 'APPLY args 2) (flet ((default-apply (fun arguments) - (let ((form (c1funcall (list* '#'APPLY fun arguments)))) - (when (and (consp fun) (eq (first fun) 'FUNCTION)) - (let* ((fname (second fun)) - (type (get-return-type fname))) - (when type - (setf (c1form-type form) type)))) - form))) + (let ((form (c1funcall (list* '#'APPLY fun arguments)))) + (when (and (consp fun) (eq (first fun) 'FUNCTION)) + (let* ((fname (second fun)) + (type (get-return-type fname))) + (when type + (setf (c1form-type form) type)))) + form))) (let* ((fun (first args)) - (arguments (rest args))) + (arguments (rest args))) (cond ((eql (first (last arguments)) 'clos::.combined-method-args.) - ;; Uses frames instead of lists as last argumennt - (default-apply fun arguments)) - ((and (consp fun) - (eq (first fun) 'LAMBDA)) - (optimize-funcall/apply-lambda (cdr fun) arguments t)) - ((and (consp fun) - (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (optimize-funcall/apply-lambda (cdr fun) arguments t)) - ((and (consp fun) - (eq (first fun) 'FUNCTION) - (consp (second fun)) - (member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK))) - (c1apply (list* (second fun) arguments))) - (t - (default-apply fun arguments)))))) + ;; Uses frames instead of lists as last argumennt + (default-apply fun arguments)) + ((and (consp fun) + (eq (first fun) 'LAMBDA)) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) + ((and (consp fun) + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) + ((and (consp fun) + (eq (first fun) 'FUNCTION) + (consp (second fun)) + (member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK))) + (c1apply (list* (second fun) arguments))) + (t + (default-apply fun arguments)))))) ;;---------------------------------------------------------------------- ;; We transform BOOLE into the individual operations, which have @@ -52,23 +52,23 @@ (define-compiler-macro boole (&whole form op-code op1 op2) (or (and (constantp op-code *cmp-env*) - (case (ext:constant-form-value op-code *cmp-env*) - (#. boole-clr `(progn ,op1 ,op2 0)) - (#. boole-set `(progn ,op1 ,op2 -1)) - (#. boole-1 `(prog1 ,op1 ,op2)) - (#. boole-2 `(progn ,op1 ,op2)) - (#. boole-c1 `(prog1 (lognot ,op1) ,op2)) - (#. boole-c2 `(progn ,op1 (lognot ,op2))) - (#. boole-and `(logand ,op1 ,op2)) - (#. boole-ior `(logior ,op1 ,op2)) - (#. boole-xor `(logxor ,op1 ,op2)) - (#. boole-eqv `(logeqv ,op1 ,op2)) - (#. boole-nand `(lognand ,op1 ,op2)) - (#. boole-nor `(lognor ,op1 ,op2)) - (#. boole-andc1 `(logandc1 ,op1 ,op2)) - (#. boole-andc2 `(logandc2 ,op1 ,op2)) - (#. boole-orc1 `(logorc1 ,op1 ,op2)) - (#. boole-orc2 `(logorc2 ,op1 ,op2)))) + (case (ext:constant-form-value op-code *cmp-env*) + (#. boole-clr `(progn ,op1 ,op2 0)) + (#. boole-set `(progn ,op1 ,op2 -1)) + (#. boole-1 `(prog1 ,op1 ,op2)) + (#. boole-2 `(progn ,op1 ,op2)) + (#. boole-c1 `(prog1 (lognot ,op1) ,op2)) + (#. boole-c2 `(progn ,op1 (lognot ,op2))) + (#. boole-and `(logand ,op1 ,op2)) + (#. boole-ior `(logior ,op1 ,op2)) + (#. boole-xor `(logxor ,op1 ,op2)) + (#. boole-eqv `(logeqv ,op1 ,op2)) + (#. boole-nand `(lognand ,op1 ,op2)) + (#. boole-nor `(lognor ,op1 ,op2)) + (#. boole-andc1 `(logandc1 ,op1 ,op2)) + (#. boole-andc2 `(logandc2 ,op1 ,op2)) + (#. boole-orc1 `(logorc1 ,op1 ,op2)) + (#. boole-orc2 `(logorc2 ,op1 ,op2)))) form)) ;---------------------------------------------------------------------- @@ -76,10 +76,10 @@ ;; Return the most particular type we can EASILY obtain from x. (defun result-type (x) (cond ((symbolp x) - (c1form-primary-type (c1expr x))) - ((constantp x) - (type-of x)) - ((and (consp x) (eq (car x) 'the)) - (second x)) - (t t))) + (c1form-primary-type (c1expr x))) + ((constantp x) + (type-of x)) + ((and (consp x) (eq (car x) 'the)) + (second x)) + (t t))) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index a21fce20f..b45343250 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -109,34 +109,34 @@ running the compiler. It may be updated by running ") ;;; 4. lexi[j], for lexical variables in local functions ;;; 5. CLVi, for lexical variables in closures -(defvar *lcl* 0) ; number of local variables +(defvar *lcl* 0) ; number of local variables #-new-cmp -(defvar *temp* 0) ; number of temporary variables +(defvar *temp* 0) ; number of temporary variables #-new-cmp -(defvar *max-temp* 0) ; maximum *temp* reached +(defvar *max-temp* 0) ; maximum *temp* reached -(defvar *level* 0) ; nesting level for local functions +(defvar *level* 0) ; nesting level for local functions -(defvar *lex* 0) ; number of lexical variables in local functions -(defvar *max-lex* 0) ; maximum *lex* reached +(defvar *lex* 0) ; number of lexical variables in local functions +(defvar *max-lex* 0) ; maximum *lex* reached -(defvar *env* 0) ; number of variables in current form -(defvar *max-env* 0) ; maximum *env* in whole function -(defvar *env-lvl* 0) ; number of levels of environments +(defvar *env* 0) ; number of variables in current form +(defvar *max-env* 0) ; maximum *env* in whole function +(defvar *env-lvl* 0) ; number of levels of environments #-new-cmp -(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls +(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls #-new-cmp (defvar *ihs-used-p* nil) ; function must be registered in IHS? #-new-cmp -(defvar *next-cmacro* 0) ; holds the last cmacro number used. -(defvar *next-cfun* 0) ; holds the last cfun used. +(defvar *next-cmacro* 0) ; holds the last cmacro number used. +(defvar *next-cfun* 0) ; holds the last cfun used. ;;; ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. ;;; If possible, *tail-recursion-info* holds -;; ( c1-lambda-form required-arg .... required-arg ), +;; ( c1-lambda-form required-arg .... required-arg ), ;;; where each required-arg is a var-object. ;;; (defvar *tail-recursion-info* nil) @@ -147,13 +147,13 @@ running the compiler. It may be updated by running ") ;;; ;;; *last-label* holds the label# of the last used label. ;;; *exit* holds an 'exit', which is -;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, -;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or -;; RETURN-OBJECT). +;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, +;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or +;; RETURN-OBJECT). ;;; *unwind-exit* holds a list consisting of: -;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, -;; JUMP, BDS-BIND (each pushed for a single special binding), or a -;; LCL (which holds the bind stack pointer used to unbind). +;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, +;; JUMP, BDS-BIND (each pushed for a single special binding), or a +;; LCL (which holds the bind stack pointer used to unbind). ;;; (defvar *last-label* 0) (defvar *exit*) @@ -172,7 +172,7 @@ variable-record = (:block block-name) | (var-name {:special | nil} bound-p) | (symbol si::symbol-macro macro-function) | CB | LB | UNWIND-PROTECT -macro-record = (function-name function) | +macro-record = (function-name function) | (macro-name si::macro macro-function) CB | LB | UNWIND-PROTECT @@ -245,47 +245,47 @@ lines are inserted, but the order is preserved") #-new-cmp (defvar *not-compile-time* nil) -(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* - ; or *temporary-objects* -(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* -(defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }* -(defvar *load-objects* nil) ; hash with association object -> vv-location -(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, +(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* + ; or *temporary-objects* +(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* +(defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }* +(defvar *load-objects* nil) ; hash with association object -> vv-location +(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, ;;; where each vv-index should be given an object before ;;; defining the current function during loading process. (defvar *setf-definitions* nil) ; C forms to find out (SETF fname) locations -(defvar *optimizable-constants* nil) ; (value . c1form) pairs for inlining constants +(defvar *optimizable-constants* nil) ; (value . c1form) pairs for inlining constants (defvar *use-static-constants-p* ; T/NIL flag to determine whether one may #+ecl-min t #-ecl-min nil) ; generate lisp constant values as C structs -(defvar *static-constants* nil) ; constants that can be built as C values +(defvar *static-constants* nil) ; constants that can be built as C values ; holds { ( object c-variable constant ) }* -(defvar *compiler-constants* nil) ; a vector with all constants - ; only used in COMPILE +(defvar *compiler-constants* nil) ; a vector with all constants + ; only used in COMPILE -(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions - ; with fixed number of arguments. - ; watch out for multiple values. +(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions + ; with fixed number of arguments. + ; watch out for multiple values. -(defvar *global-vars* nil) ; variables declared special -(defvar *global-funs* nil) ; holds { fun }* -(defvar *use-c-global* nil) ; honor si::c-global declaration -(defvar *global-cfuns-array* nil) ; holds { fun }* -(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* -(defvar *local-funs* nil) ; holds { fun }* -(defvar *top-level-forms* nil) ; holds { top-level-form }* -(defvar *make-forms* nil) ; holds { top-level-form }* +(defvar *global-vars* nil) ; variables declared special +(defvar *global-funs* nil) ; holds { fun }* +(defvar *use-c-global* nil) ; honor si::c-global declaration +(defvar *global-cfuns-array* nil) ; holds { fun }* +(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* +(defvar *local-funs* nil) ; holds { fun }* +(defvar *top-level-forms* nil) ; holds { top-level-form }* +(defvar *make-forms* nil) ; holds { top-level-form }* ;;; ;;; top-level-form: -;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp ) -;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp ) -;;; | ( 'ORDINARY' expr ) -;;; | ( 'DECLARE' var-name-vv ) -;;; | ( 'DEFVAR' var-name-vv expr doc-vv ) -;;; | ( 'CLINES' string* ) -;;; | ( 'LOAD-TIME-VALUE' vv ) +;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp ) +;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp ) +;;; | ( 'ORDINARY' expr ) +;;; | ( 'DECLARE' var-name-vv ) +;;; | ( 'DEFVAR' var-name-vv expr doc-vv ) +;;; | ( 'CLINES' string* ) +;;; | ( 'LOAD-TIME-VALUE' vv ) ;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). (defvar *global-entries* nil) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 5561735d8..4c0f3c894 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -19,16 +19,16 @@ (let ((test (c1expr (car args)))) ;; Resolve IF expressions with constant arguments (multiple-value-bind (constant-p value) - (c1form-constant-p test) + (c1form-constant-p test) (when constant-p - (return-from c1if - (if value (second args) (third args))))) + (return-from c1if + (if value (second args) (third args))))) ;; Otherwise, normal IF form (let* ((true-branch (c1expr (second args))) (false-branch (c1expr (third args)))) (make-c1form* 'IF :type (values-type-or (c1form-type true-branch) - (c1form-type false-branch)) + (c1form-type false-branch)) :args test true-branch false-branch)))) (defun c1not (args) @@ -37,9 +37,9 @@ ;; When the argument is constant, we can just return ;; a constant as well. (multiple-value-bind (constant-p value) - (c1form-constant-p value) + (c1form-constant-p value) (when constant-p - (return-from c1not (not value)))) + (return-from c1not (not value)))) (make-c1form* 'FMLA-NOT :type '(member t nil) :args value))) @@ -63,42 +63,42 @@ (if (null args) (c1nil) (let* ((values (c1args* args)) - (last (first (last values))) - (butlast (butlast values))) + (last (first (last values))) + (butlast (butlast values))) ;; (OR x) => x - (if butlast - (make-c1form* 'FMLA-OR - :type (reduce #'type-or butlast + (if butlast + (make-c1form* 'FMLA-OR + :type (reduce #'type-or butlast :key #'c1form-primary-type :initial-value (c1form-primary-type last)) - :args butlast last) - last)))) + :args butlast last) + last)))) (defun c2if (c1form fmla form1 form2) (declare (ignore c1form)) ;; FIXME! Optimize when FORM1 or FORM2 are constants (cond ((and (eq *destination* 'TRASH) - (eq (c1form-name form2) 'LOCATION)) - ;; Optimize (IF condition true-branch) or a situation in which - ;; the false branch can be discarded. - (with-optional-exit-label (false-label) - (let ((*destination* `(JUMP-FALSE ,false-label))) - (c2expr* fmla)) - (c2expr form1))) - ((and (eq *destination* 'TRASH) - (eq (c1form-name form1) 'LOCATION)) - ;; Optimize (IF condition useless-value false-branch) when - ;; the true branch can be discarded. - (with-optional-exit-label (true-label) - (let ((*destination* `(JUMP-TRUE ,true-label))) - (c2expr* fmla)) - (c2expr form2))) - (t - (with-exit-label (false-label) - (let ((*destination* `(JUMP-FALSE ,false-label))) - (c2expr* fmla)) - (c2expr form1)) - (c2expr form2)))) + (eq (c1form-name form2) 'LOCATION)) + ;; Optimize (IF condition true-branch) or a situation in which + ;; the false branch can be discarded. + (with-optional-exit-label (false-label) + (let ((*destination* `(JUMP-FALSE ,false-label))) + (c2expr* fmla)) + (c2expr form1))) + ((and (eq *destination* 'TRASH) + (eq (c1form-name form1) 'LOCATION)) + ;; Optimize (IF condition useless-value false-branch) when + ;; the true branch can be discarded. + (with-optional-exit-label (true-label) + (let ((*destination* `(JUMP-TRUE ,true-label))) + (c2expr* fmla)) + (c2expr form2))) + (t + (with-exit-label (false-label) + (let ((*destination* `(JUMP-FALSE ,false-label))) + (c2expr* fmla)) + (c2expr form1)) + (c2expr form2)))) (defun negate-argument (inlined-arg dest-loc) (let* ((loc (second inlined-arg)) @@ -142,26 +142,26 @@ (declare (ignore c1form)) (if (jump-false-destination-p *destination*) (progn - (mapc #'c2expr* butlast) - (c2expr last)) + (mapc #'c2expr* butlast) + (c2expr last)) (with-exit-label (normal-exit) - (with-exit-label (false-label) - (let ((*destination* `(JUMP-FALSE ,false-label))) - (mapc #'c2expr* butlast)) - (c2expr last)) - (unwind-exit nil)))) + (with-exit-label (false-label) + (let ((*destination* `(JUMP-FALSE ,false-label))) + (mapc #'c2expr* butlast)) + (c2expr last)) + (unwind-exit nil)))) (defun c2fmla-or (c1form butlast last) (declare (ignore c1form)) (cond ((jump-true-destination-p *destination*) - (mapc #'c2expr* butlast) - (c2expr last)) - ((jump-false-destination-p *destination*) - (with-exit-label (true-label) - (let ((*destination* `(JUMP-TRUE ,true-label))) - (mapc #'c2expr* butlast)) - (c2expr last)) - (unwind-exit t)) + (mapc #'c2expr* butlast) + (c2expr last)) + ((jump-false-destination-p *destination*) + (with-exit-label (true-label) + (let ((*destination* `(JUMP-TRUE ,true-label))) + (mapc #'c2expr* butlast)) + (c2expr last)) + (unwind-exit t)) (t (with-exit-label (common-exit) (with-exit-label (normal-exit) @@ -183,11 +183,11 @@ (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) {"))) (cond ((unwind-no-exit label) - (incf *opened-c-braces*) - (wt-nl) (wt-go label) - (wt-nl-close-brace)) - (t - (wt " ") (wt-go label) (wt " }")))) + (incf *opened-c-braces*) + (wt-nl) (wt-go label) + (wt-nl-close-brace)) + (t + (wt " ") (wt-go label) (wt " }")))) ((null value)) (t (unwind-no-exit label) @@ -203,12 +203,12 @@ (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) {"))) - (cond ((unwind-no-exit label) - (incf *opened-c-braces*) - (wt-nl) (wt-go label) - (wt-nl-close-brace)) - (t - (wt " ") (wt-go label) (wt " }")))) + (cond ((unwind-no-exit label) + (incf *opened-c-braces*) + (wt-nl) (wt-go label) + (wt-nl-close-brace)) + (t + (wt " ") (wt-go label) (wt " }")))) (value) (t (unwind-no-exit label) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index d5f6f81f7..731cdf2b5 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -16,8 +16,8 @@ ;;; Valid property names for open coded functions are: ;;; :INLINE-ALWAYS -;;; :INLINE-SAFE safe-compile only -;;; :INLINE-UNSAFE non-safe-compile only +;;; :INLINE-SAFE safe-compile only +;;; :INLINE-UNSAFE non-safe-compile only ;;; ;;; Each property is a list of 'inline-info's, where each inline-info is: ;;; ( types { type | boolean } { string | function } ). @@ -37,7 +37,7 @@ (make-temp-var) (let ((var (make-lcl-var :rep-type out-rep-type :type value-type))) - (open-inline-block) + (open-inline-block) (wt-nl (rep-type->c-name out-rep-type) " " var ";") var)))) @@ -191,4 +191,4 @@ (defun function-may-change-sp (fname) (not (or (get-sysprop fname 'no-side-effects) - (get-sysprop fname 'no-sp-change)))) + (get-sysprop fname 'no-sp-change)))) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 56dc15a46..0fa6c501d 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -16,33 +16,33 @@ ;;; During Pass1, a lambda-list ;;; -;;; ( { var }* -;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] -;;; [ &rest var ] -;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* -;;; [&allow-other-keys]] -;;; [ &aux {var | (var [initform])}*] +;;; ( { var }* +;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] +;;; [ &rest var ] +;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* +;;; [&allow-other-keys]] +;;; [ &aux {var | (var [initform])}*] ;;; ) ;;; ;;; is transformed into ;;; -;;; ( ( { var }* ) ; required -;;; ( { var initform svar }* ) ; optional -;;; { var | nil } ; rest -;;; allow-other-keys-flag -;;; ( { kwd-vv-index var initform svar }* ) ; key +;;; ( ( { var }* ) ; required +;;; ( { var initform svar }* ) ; optional +;;; { var | nil } ; rest +;;; allow-other-keys-flag +;;; ( { kwd-vv-index var initform svar }* ) ; key ;;; ) ;;; ;;; where -;;; svar: NIL ; means svar is not supplied -;;; | var +;;; svar: NIL ; means svar is not supplied +;;; | var ;;; ;;; &aux parameters will be embedded into LET*. ;;; ;;; c1lambda-expr receives -;;; ( lambda-list { doc | decl }* . body ) +;;; ( lambda-list { doc | decl }* . body ) ;;; and returns -;;; ( lambda info-object lambda-list' doc body' ) +;;; ( lambda info-object lambda-list' doc body' ) ;;; ;;; Doc is NIL if no doc string is supplied. ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are @@ -65,9 +65,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (let (narg) (and (not (eq (fun-closure fun) 'CLOSURE)) - (= (fun-minarg fun) (setf narg (fun-maxarg fun))) - (<= narg si::c-arguments-limit) - narg))) + (= (fun-minarg fun) (setf narg (fun-maxarg fun))) + (<= narg si::c-arguments-limit) + narg))) (defun add-to-fun-referenced-vars (fun var-list) (loop with new-vars = (fun-referenced-vars fun) @@ -75,48 +75,48 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." with change = nil for v in var-list when (and (not (member v locals :test #'eq)) - (not (member v new-vars :test #'eq))) + (not (member v new-vars :test #'eq))) do (setf change t new-vars (cons v new-vars)) finally (when change - (setf (fun-referenced-vars fun) new-vars) - (return t)))) + (setf (fun-referenced-vars fun) new-vars) + (return t)))) (defun add-to-fun-referenced-funs (fun fun-list) (loop with new-funs = (fun-referenced-funs fun) with change = nil for f in fun-list when (and (not (eq fun f)) - (not (member f new-funs :test #'eq)) - (not (child-function-p fun f))) + (not (member f new-funs :test #'eq)) + (not (child-function-p fun f))) do (setf change t - new-funs (cons f new-funs) - (fun-referencing-funs f) (cons fun (fun-referencing-funs f))) + new-funs (cons f new-funs) + (fun-referencing-funs f) (cons fun (fun-referencing-funs f))) finally (when change - (setf (fun-referenced-funs fun) new-funs) - (return t)))) + (setf (fun-referenced-funs fun) new-funs) + (return t)))) (defun c1compile-function (lambda-list-and-body &key (fun (make-fun)) - (name (fun-name fun)) (CB/LB 'CB)) + (name (fun-name fun)) (CB/LB 'CB)) (let ((lambda (if name - `(ext:lambda-block ,name ,@lambda-list-and-body) - `(lambda ,@lambda-list-and-body)))) + `(ext:lambda-block ,name ,@lambda-list-and-body) + `(lambda ,@lambda-list-and-body)))) (setf (fun-name fun) name - (fun-lambda-expression fun) lambda - (fun-parent fun) *current-function*)) + (fun-lambda-expression fun) lambda + (fun-parent fun) *current-function*)) (when *current-function* (push fun (fun-child-funs *current-function*))) (let* ((*current-function* fun) - (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB))) - (setjmps *setjmps*) - (decl (si::process-declarations (rest lambda-list-and-body))) - (global (and *use-c-global* - (assoc 'SI::C-GLOBAL decl) - (setf (fun-global fun) T))) - (no-entry (assoc 'SI::C-LOCAL decl)) - (lambda-expr (c1lambda-expr lambda-list-and-body + (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB))) + (setjmps *setjmps*) + (decl (si::process-declarations (rest lambda-list-and-body))) + (global (and *use-c-global* + (assoc 'SI::C-GLOBAL decl) + (setf (fun-global fun) T))) + (no-entry (assoc 'SI::C-LOCAL decl)) + (lambda-expr (c1lambda-expr lambda-list-and-body name - (si::function-block-name name))) - cfun exported minarg maxarg) + (si::function-block-name name))) + cfun exported minarg maxarg) (when (and no-entry (policy-debug-ihs-frame)) (setf no-entry nil) (cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name)) @@ -124,29 +124,29 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (setf (c1form-volatile lambda-expr) t)) (setf (fun-lambda fun) lambda-expr) (if global - (multiple-value-setq (cfun exported) (exported-fname name)) - (setf cfun (next-cfun "LC~D~A" name) exported nil)) + (multiple-value-setq (cfun exported) (exported-fname name)) + (setf cfun (next-cfun "LC~D~A" name) exported nil)) #+ecl-min (when (member name c::*in-all-symbols-functions*) (setf no-entry t)) (if exported - ;; Check whether the function was proclaimed to have a certain - ;; number of arguments, and otherwise produce a function with - ;; a flexible signature. - (progn - (multiple-value-setq (minarg maxarg) (get-proclaimed-narg name)) + ;; Check whether the function was proclaimed to have a certain + ;; number of arguments, and otherwise produce a function with + ;; a flexible signature. + (progn + (multiple-value-setq (minarg maxarg) (get-proclaimed-narg name)) (format t "~&;;; Function ~A proclaimed (~A,~A)" name minarg maxarg) - (unless minarg - (setf minarg 0 maxarg call-arguments-limit))) - (multiple-value-setq (minarg maxarg) - (lambda-form-allowed-nargs lambda-expr))) + (unless minarg + (setf minarg 0 maxarg call-arguments-limit))) + (multiple-value-setq (minarg maxarg) + (lambda-form-allowed-nargs lambda-expr))) (setf (fun-cfun fun) cfun - (fun-exported fun) exported - (fun-closure fun) nil - (fun-minarg fun) minarg - (fun-maxarg fun) maxarg - (fun-description fun) name - (fun-no-entry fun) no-entry) + (fun-exported fun) exported + (fun-closure fun) nil + (fun-minarg fun) minarg + (fun-maxarg fun) maxarg + (fun-description fun) name + (fun-no-entry fun) no-entry) (loop for child in (fun-child-funs fun) do (add-to-fun-referenced-vars fun (fun-referenced-vars child)) do (add-to-fun-referenced-funs fun (fun-referenced-funs child))) @@ -167,10 +167,10 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (defun c1lambda-expr (lambda-expr function-name block-name &aux doc body ss is ts other-decls - new-variables - (type-checks '()) - (*permanent-data* t) - (old-env *cmp-env*) + new-variables + (type-checks '()) + (*permanent-data* t) + (old-env *cmp-env*) (*cmp-env* (cmp-env-copy))) (declare (si::c-local)) @@ -183,56 +183,56 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (when block-name (setq body (list (cons 'BLOCK (cons block-name body))))) (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys aux-vars) + allow-other-keys aux-vars) (cmp-process-lambda-list (car lambda-expr)) (do ((specs (setq requireds (cdr requireds)) (cdr specs))) - ((endp specs)) + ((endp specs)) (let* ((name (first specs)) - (var (c1make-var name ss is ts))) - (push var type-checks) - (setf (first specs) var) - (push-vars var))) + (var (c1make-var name ss is ts))) + (push var type-checks) + (setf (first specs) var) + (push-vars var))) (do ((specs (setq optionals (cdr optionals)) (cdddr specs))) - ((endp specs)) + ((endp specs)) (let* ((name (first specs)) - (var (c1make-var name ss is ts)) - (init (second specs)) - (flag (third specs))) - (setq init (if init - (and-form-type (var-type var) (c1expr init) init - :safe "In (LAMBDA ~a...)" function-name) - (default-init var))) - (push var type-checks) - (push-vars var) - (when flag - (push-vars (setq flag (c1make-var flag ss is ts)))) - (setf (first specs) var - (second specs) init - (third specs) flag))) + (var (c1make-var name ss is ts)) + (init (second specs)) + (flag (third specs))) + (setq init (if init + (and-form-type (var-type var) (c1expr init) init + :safe "In (LAMBDA ~a...)" function-name) + (default-init var))) + (push var type-checks) + (push-vars var) + (when flag + (push-vars (setq flag (c1make-var flag ss is ts)))) + (setf (first specs) var + (second specs) init + (third specs) flag))) (when rest (push-vars (setq rest (c1make-var rest ss is ts)))) (do ((specs (setq keywords (cdr keywords)) (cddddr specs))) - ((endp specs)) + ((endp specs)) (let* ((key (first specs)) - (name (second specs)) - (var (c1make-var name ss is ts)) - (init (third specs)) - (flag (fourth specs))) - (setq init (if init - (and-form-type (var-type var) (c1expr init) init - :safe "In (LAMBDA ~a...)" function-name) - (default-init var))) - (push var type-checks) - (push-vars var) - (when flag - (push-vars (setq flag (c1make-var flag ss is ts)))) - (setf (second specs) var - (third specs) init - (fourth specs) flag))) + (name (second specs)) + (var (c1make-var name ss is ts)) + (init (third specs)) + (flag (fourth specs))) + (setq init (if init + (and-form-type (var-type var) (c1expr init) init + :safe "In (LAMBDA ~a...)" function-name) + (default-init var))) + (push var type-checks) + (push-vars var) + (when flag + (push-vars (setq flag (c1make-var flag ss is ts)))) + (setf (second specs) var + (third specs) init + (fourth specs) flag))) ;; Make other declarations take effect right now (setf *cmp-env* (reduce #'add-one-declaration other-decls @@ -254,7 +254,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." for init = (second spec) collect (list name init))) (new-variables (cmp-env-new-variables *cmp-env* old-env)) - (already-declared-names (set-difference (mapcar #'var-name new-variables) + (already-declared-names (set-difference (mapcar #'var-name new-variables) (mapcar #'car let-vars)))) ;; Gather declarations for &aux variables, either special... (let ((specials (set-difference ss already-declared-names))) @@ -268,8 +268,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (push `(ignorable ,@ignorables) declarations))) ;; ...or type declarations (loop for (var . type) in ts - unless (member var already-declared-names) - do (push `(type ,type ,var) declarations)) + unless (member var already-declared-names) + do (push `(type ,type ,var) declarations)) ;; ...create the enclosing LET* form for the &aux variables (when (or let-vars declarations) (setq body `((let* ,let-vars @@ -292,71 +292,71 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (defun lambda-form-allowed-nargs (lambda) (let ((minarg 0) - (maxarg call-arguments-limit)) + (maxarg call-arguments-limit)) (destructuring-bind (requireds optionals rest key-flag keywords a-o-k) - (c1form-arg 0 lambda) + (c1form-arg 0 lambda) (when (and (null rest) (not key-flag) (not a-o-k)) - (setf minarg (length requireds) - maxarg (+ minarg (/ (length optionals) 3))))) + (setf minarg (length requireds) + maxarg (+ minarg (/ (length optionals) 3))))) (values minarg maxarg))) #| Steps: 1. defun creates declarations for requireds + va_alist 2. c2lambda-expr adds declarations for: - unboxed requireds - lexical optionals (+ supplied-p), rest, keywords (+ supplied-p) + unboxed requireds + lexical optionals (+ supplied-p), rest, keywords (+ supplied-p) Lexical optionals and keywords can be unboxed if: - a. there is more then one reference in the body - b. they are not referenced in closures + a. there is more then one reference in the body + b. they are not referenced in closures 3. binding is performed for: - special or unboxed requireds - optionals, rest, keywords + special or unboxed requireds + optionals, rest, keywords 4. the function name is optionally pushed onto the IHS when the caller asks for it. |# (defun c2lambda-expr (lambda-list body cfun fname use-narg required-lcls closure-type - &aux (requireds (first lambda-list)) - (optionals (second lambda-list)) - (rest (third lambda-list)) rest-loc - (keywords (fifth lambda-list)) - (allow-other-keys (sixth lambda-list)) - (nreq (length requireds)) - (nopt (/ (length optionals) 3)) - (nkey (/ (length keywords) 4)) - (varargs (or optionals rest keywords allow-other-keys)) + &aux (requireds (first lambda-list)) + (optionals (second lambda-list)) + (rest (third lambda-list)) rest-loc + (keywords (fifth lambda-list)) + (allow-other-keys (sixth lambda-list)) + (nreq (length requireds)) + (nopt (/ (length optionals) 3)) + (nkey (/ (length keywords) 4)) + (varargs (or optionals rest keywords allow-other-keys)) (fname-in-ihs-p (or (policy-debug-variable-bindings) (and (policy-debug-ihs-frame) fname))) - simple-varargs - (*permanent-data* t) - (*unwind-exit* *unwind-exit*) - (*env* *env*) - (*inline-blocks* 0) - (last-arg)) + simple-varargs + (*permanent-data* t) + (*unwind-exit* *unwind-exit*) + (*env* *env*) + (*inline-blocks* 0) + (last-arg)) (declare (fixnum nreq nkey)) (if (and fname ;; named function - ;; no required appears in closure, - (dolist (var (car lambda-list) t) - (declare (type var var)) - (when (var-ref-ccb var) (return nil))) - (null (second lambda-list)) ;; no optionals, - (null (third lambda-list)) ;; no rest parameter, and - (null (fourth lambda-list))) ;; no keywords. + ;; no required appears in closure, + (dolist (var (car lambda-list) t) + (declare (type var var)) + (when (var-ref-ccb var) (return nil))) + (null (second lambda-list)) ;; no optionals, + (null (third lambda-list)) ;; no rest parameter, and + (null (fourth lambda-list))) ;; no keywords. (setf *tail-recursion-info* (cons *tail-recursion-info* (car lambda-list))) (setf *tail-recursion-info* nil)) ;; check arguments (when (policy-check-nargs) (if (and use-narg (not varargs)) - (wt-nl "if (ecl_unlikely(narg!=" nreq ")) FEwrong_num_arguments_anonym();") - (when varargs - (when requireds - (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();")) - (unless (or rest keywords allow-other-keys) - (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();")))) + (wt-nl "if (ecl_unlikely(narg!=" nreq ")) FEwrong_num_arguments_anonym();") + (when varargs + (when requireds + (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();")) + (unless (or rest keywords allow-other-keys) + (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();")))) (open-inline-block)) ;; If the number of required arguments exceeds the number of variables we @@ -364,25 +364,25 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; of optionals, which will eventually get passed in the lisp stack. (when (> nreq si::c-arguments-limit) (setf nopt (+ nopt (- nreq si::c-arguments-limit)) - nreq si::c-arguments-limit) + nreq si::c-arguments-limit) (setf optionals (nconc (loop for var in (subseq requireds si::c-arguments-limit) - nconc (list var *c1nil* NIL)) - optionals) - requireds (subseq requireds 0 si::c-arguments-limit) - varargs t)) + nconc (list var *c1nil* NIL)) + optionals) + requireds (subseq requireds 0 si::c-arguments-limit) + varargs t)) ;; For each variable, set its var-loc. ;; For optional and keyword parameters, and lexical variables which ;; can be unboxed, this will be a new LCL. ;; The bind step later will assign to such variable. (labels ((wt-decl (var) - (let ((lcl (next-lcl (var-name var)))) - (wt-nl) - (wt (rep-type->c-name (var-rep-type var)) " " *volatile* lcl ";") - lcl)) - (do-decl (var) - (when (local var) ; no LCL needed for SPECIAL or LEX - (setf (var-loc var) (wt-decl var))))) + (let ((lcl (next-lcl (var-name var)))) + (wt-nl) + (wt (rep-type->c-name (var-rep-type var)) " " *volatile* lcl ";") + lcl)) + (do-decl (var) + (when (local var) ; no LCL needed for SPECIAL or LEX + (setf (var-loc var) (wt-decl var))))) ;; Declare unboxed required arguments (loop for var in requireds when (unboxed var) @@ -390,35 +390,35 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; dont create rest or varargs if not used (when (and rest (< (var-ref rest) 1)) (setq rest nil - varargs (or optionals keywords allow-other-keys))) + varargs (or optionals keywords allow-other-keys))) ;; Declare &optional variables (do ((opt optionals (cdddr opt))) - ((endp opt)) + ((endp opt)) (do-decl (first opt)) (when (third opt) (do-decl (third opt)))) ;; Declare &rest variables (when rest (setq rest-loc (wt-decl rest))) ;; Declare &key variables (do ((key keywords (cddddr key))) - ((endp key)) + ((endp key)) (do-decl (second key)) (when (fourth key) (do-decl (fourth key))))) ;; Declare and assign the variable arguments pointer (when varargs (flet ((last-variable () - (cond (required-lcls - (first (last required-lcls))) - ((eq closure-type 'LEXICAL) - (format nil "lex~D" (1- *level*))) - (t "narg")))) + (cond (required-lcls + (first (last required-lcls))) + ((eq closure-type 'LEXICAL) + (format nil "lex~D" (1- *level*))) + (t "narg")))) (if (setq simple-varargs (and (not (or rest keywords allow-other-keys)) - (< (+ nreq nopt) 30))) - (wt-nl "va_list args; va_start(args," - (last-variable) - ");") - (wt-nl "ecl_va_list args; ecl_va_start(args," - (last-variable) ",narg," nreq ");")))) + (< (+ nreq nopt) 30))) + (wt-nl "va_list args; va_start(args," + (last-variable) + ");") + (wt-nl "ecl_va_list args; ecl_va_start(args," + (last-variable) ",narg," nreq ");")))) ;; Bind required argumens. Produces C statements for unboxed variables, ;; which is why it is done after all declarations. @@ -431,7 +431,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (when (policy-debug-variable-bindings) (build-debug-lexical-env (reverse requireds) t)) (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname) - ",_ecl_debug_env);")) + ",_ecl_debug_env);")) ;; Bind optional parameters as long as there remain arguments. (when optionals @@ -444,34 +444,34 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (wt-nl-open-brace) (wt-nl "int i = " nreq ";") (do ((opt optionals (cdddr opt))) - ((endp opt)) - (wt-nl "if (i >= narg) {") - (let ((*opened-c-braces* (1+ *opened-c-braces*))) - (bind-init (second opt) (first opt)) - (when (third opt) (bind nil (third opt)))) - (wt-nl "} else {") - (let ((*opened-c-braces* (1+ *opened-c-braces*)) - (*unwind-exit* *unwind-exit*)) - (wt-nl "i++;") - (bind va-arg-loc (first opt)) - (when (third opt) (bind t (third opt)))) - (wt-nl "}")) + ((endp opt)) + (wt-nl "if (i >= narg) {") + (let ((*opened-c-braces* (1+ *opened-c-braces*))) + (bind-init (second opt) (first opt)) + (when (third opt) (bind nil (third opt)))) + (wt-nl "} else {") + (let ((*opened-c-braces* (1+ *opened-c-braces*)) + (*unwind-exit* *unwind-exit*)) + (wt-nl "i++;") + (bind va-arg-loc (first opt)) + (when (third opt) (bind t (third opt)))) + (wt-nl "}")) (wt-nl-close-brace))) (when (or rest keywords allow-other-keys) (cond ((not (or keywords allow-other-keys)) - (wt-nl rest-loc " = cl_grab_rest_args(args);")) - (t - (cond (keywords - (wt-nl-open-brace) ;; Brace [1] - (wt-nl "cl_object keyvars[" (* 2 nkey) "];") - (wt-nl "cl_parse_key(args," nkey "," cfun "keys,keyvars")) - (t - (wt-nl "cl_parse_key(args,0,NULL,NULL"))) - ;; This explicit coercion is required to remove the "volatile" - ;; declaration on some variables. - (if rest (wt ",(cl_object*)&" rest-loc) (wt ",NULL")) - (wt (if allow-other-keys ",TRUE);" ",FALSE);")))) + (wt-nl rest-loc " = cl_grab_rest_args(args);")) + (t + (cond (keywords + (wt-nl-open-brace) ;; Brace [1] + (wt-nl "cl_object keyvars[" (* 2 nkey) "];") + (wt-nl "cl_parse_key(args," nkey "," cfun "keys,keyvars")) + (t + (wt-nl "cl_parse_key(args,0,NULL,NULL"))) + ;; This explicit coercion is required to remove the "volatile" + ;; declaration on some variables. + (if rest (wt ",(cl_object*)&" rest-loc) (wt ",NULL")) + (wt (if allow-other-keys ",TRUE);" ",FALSE);")))) (when rest (bind rest-loc rest))) (when varargs @@ -484,35 +484,35 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (i 0 (1+ i))) ((endp kwd) (when all-kwd - (wt-nl-h "#define " cfun "keys (&" (add-keywords (nreverse all-kwd)) ")") - (wt-nl-close-brace))) ;; Matches [1] + (wt-nl-h "#define " cfun "keys (&" (add-keywords (nreverse all-kwd)) ")") + (wt-nl-close-brace))) ;; Matches [1] (declare (fixnum i)) (push (first kwd) all-kwd) (let ((key (first kwd)) - (var (second kwd)) - (init (third kwd)) - (flag (fourth kwd))) + (var (second kwd)) + (init (third kwd)) + (flag (fourth kwd))) (cond ((and (eq (c1form-name init) 'LOCATION) - (null (c1form-arg 0 init))) - ;; no initform - ;; ECL_NIL has been set in keyvars if keyword parameter is not supplied. - (setf (second KEYVARS[i]) i) - (bind KEYVARS[i] var)) - (t - ;; with initform - (setf (second KEYVARS[i]) (+ nkey i)) - (wt-nl "if (Null(") (wt-loc KEYVARS[i]) (wt ")) {") - (let ((*unwind-exit* *unwind-exit*) - (*opened-c-braces* (1+ *opened-c-braces*))) - (bind-init init var)) - (wt-nl "} else {") - (let ((*opened-c-braces* (1+ *opened-c-braces*))) - (setf (second KEYVARS[i]) i) - (bind KEYVARS[i] var)) - (wt-nl "}"))) + (null (c1form-arg 0 init))) + ;; no initform + ;; ECL_NIL has been set in keyvars if keyword parameter is not supplied. + (setf (second KEYVARS[i]) i) + (bind KEYVARS[i] var)) + (t + ;; with initform + (setf (second KEYVARS[i]) (+ nkey i)) + (wt-nl "if (Null(") (wt-loc KEYVARS[i]) (wt ")) {") + (let ((*unwind-exit* *unwind-exit*) + (*opened-c-braces* (1+ *opened-c-braces*))) + (bind-init init var)) + (wt-nl "} else {") + (let ((*opened-c-braces* (1+ *opened-c-braces*))) + (setf (second KEYVARS[i]) i) + (bind KEYVARS[i] var)) + (wt-nl "}"))) (when flag - (setf (second KEYVARS[i]) (+ nkey i)) - (bind KEYVARS[i] flag)))) + (setf (second KEYVARS[i]) (+ nkey i)) + (bind KEYVARS[i] flag)))) (when *tail-recursion-info* (push 'TAIL-RECURSION-MARK *unwind-exit*) @@ -524,90 +524,90 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (close-inline-blocks)) (defun optimize-funcall/apply-lambda (lambda-form arguments apply-p - &aux body apply-list apply-var - let-vars extra-stmts all-keys) + &aux body apply-list apply-var + let-vars extra-stmts all-keys) (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys aux-vars) + allow-other-keys aux-vars) (cmp-process-lambda-list (car lambda-form)) (when apply-p (setf apply-list (first (last arguments)) - apply-var (gensym) - arguments (butlast arguments))) + apply-var (gensym) + arguments (butlast arguments))) (setf arguments (copy-list arguments)) (do ((scan arguments (cdr scan))) - ((endp scan)) + ((endp scan)) (let ((form (first scan))) - (unless (constantp form) - (let ((aux-var (gensym))) - (push `(,aux-var ,form) let-vars) - (setf (car scan) aux-var))))) + (unless (constantp form) + (let ((aux-var (gensym))) + (push `(,aux-var ,form) let-vars) + (setf (car scan) aux-var))))) (when apply-var (push `(,apply-var ,apply-list) let-vars)) (dolist (i (cdr requireds)) (push (list i - (cond (arguments - (pop arguments)) - (apply-p - `(if ,apply-var - (pop ,apply-var) - (si::dm-too-few-arguments nil))) - (t - (cmperr "Too few arguments for lambda form ~S" + (cond (arguments + (pop arguments)) + (apply-p + `(if ,apply-var + (pop ,apply-var) + (si::dm-too-few-arguments nil))) + (t + (cmperr "Too few arguments for lambda form ~S" (cons 'LAMBDA lambda-form))))) - let-vars)) + let-vars)) (do ((scan (cdr optionals) (cdddr scan))) - ((endp scan)) + ((endp scan)) (let ((opt-var (first scan)) - (opt-flag (third scan)) - (opt-value (second scan))) - (cond (arguments - (setf let-vars - (list* `(,opt-var ,(pop arguments)) - `(,opt-flag t) - let-vars))) - (apply-p - (setf let-vars - (list* `(,opt-var (if ,apply-var - (pop ,apply-var) - ,opt-value)) - `(,opt-flag ,apply-var) - let-vars))) - (t - (setf let-vars - (list* `(,opt-var ,opt-value) - `(,opt-flag nil) - let-vars)))))) + (opt-flag (third scan)) + (opt-value (second scan))) + (cond (arguments + (setf let-vars + (list* `(,opt-var ,(pop arguments)) + `(,opt-flag t) + let-vars))) + (apply-p + (setf let-vars + (list* `(,opt-var (if ,apply-var + (pop ,apply-var) + ,opt-value)) + `(,opt-flag ,apply-var) + let-vars))) + (t + (setf let-vars + (list* `(,opt-var ,opt-value) + `(,opt-flag nil) + let-vars)))))) (when (or key-flag allow-other-keys) (unless rest - (setf rest (gensym)))) + (setf rest (gensym)))) (when rest (push `(,rest ,(if arguments - (if apply-p - `(list* ,@arguments ,apply-var) - `(list ,@arguments)) - (if apply-p apply-var nil))) - let-vars)) + (if apply-p + `(list* ,@arguments ,apply-var) + `(list ,@arguments)) + (if apply-p apply-var nil))) + let-vars)) (loop while aux-vars do (push (list (pop aux-vars) (pop aux-vars)) let-vars)) (do ((scan (cdr keywords) (cddddr scan))) - ((endp scan)) + ((endp scan)) (let ((keyword (first scan)) - (key-var (second scan)) - (key-value (third scan)) - (key-flag (or (fourth scan) (gensym)))) - (push keyword all-keys) - (setf let-vars - (list* - `(,key-var (if (eq ,key-flag 'si::missing-keyword) ,key-value ,key-flag)) - `(,key-flag (si::search-keyword ,rest ,keyword)) - let-vars)) - (when (fourth scan) - (push `(setf ,key-flag (not (eq ,key-flag 'si::missing-keyword))) - extra-stmts)))) + (key-var (second scan)) + (key-value (third scan)) + (key-flag (or (fourth scan) (gensym)))) + (push keyword all-keys) + (setf let-vars + (list* + `(,key-var (if (eq ,key-flag 'si::missing-keyword) ,key-value ,key-flag)) + `(,key-flag (si::search-keyword ,rest ,keyword)) + let-vars)) + (when (fourth scan) + (push `(setf ,key-flag (not (eq ,key-flag 'si::missing-keyword))) + extra-stmts)))) (when (and key-flag (not allow-other-keys)) (push `(si::check-keyword ,rest ',all-keys) extra-stmts)) `(let* ,(nreverse (delete-if-not #'first let-vars)) ,@(and apply-var `((declare (ignorable ,apply-var)))) ,@(multiple-value-bind (decl body) - (si::find-declarations (rest lambda-form)) - (append decl extra-stmts body))))) + (si::find-declarations (rest lambda-form)) + (append decl extra-stmts body))))) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index c812e5633..3b6b3d476 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -23,20 +23,20 @@ (invalid-let-bindings 'LET bindings)) ((null (rest bindings)) (c1let/let* 'let* bindings args)) - (t - (loop with temp - for b in bindings - if (atom b) - collect b into real-bindings - else collect (setf temp (gensym "LET")) into temp-names and - collect (cons temp (cdr b)) into temp-bindings and - collect (list (car b) temp) into real-bindings - finally - (return (c1let/let* 'let* - (nconc temp-bindings real-bindings) - `((declare (ignorable ,@temp-names) - (:read-only ,@temp-names)) - ,@args))))) + (t + (loop with temp + for b in bindings + if (atom b) + collect b into real-bindings + else collect (setf temp (gensym "LET")) into temp-names and + collect (cons temp (cdr b)) into temp-bindings and + collect (list (car b) temp) into real-bindings + finally + (return (c1let/let* 'let* + (nconc temp-bindings real-bindings) + `((declare (ignorable ,@temp-names) + (:read-only ,@temp-names)) + ,@args))))) (t (c1let/let* 'let bindings args))))) @@ -87,28 +87,28 @@ (check-args-number "LET/LET* binding" form 1 2) (setf name (first form) form (rest form)))) (let* ((var (c1make-var name specials ignoreds types)) - (type (var-type var)) + (type (var-type var)) (init (cond ((null form) - (default-init var)) - ((trivial-type-p type) - (c1expr (first form))) - (t - (c1expr `(checked-value ,type ,(first form))))))) + (default-init var)) + ((trivial-type-p type) + (c1expr (first form))) + (t + (c1expr `(checked-value ,type ,(first form))))))) ;; :read-only variable handling. Beppe (when (read-only-variable-p name other-decls) - (if (global-var-p var) - (cmpwarn "Found :READ-ONLY declaration for global var ~A" - name) - (setf (var-type var) (c1form-primary-type init))) - (multiple-value-bind (constantp value) - (c1form-constant-p init) - (when constantp - (cmp-env-register-symbol-macro name (si::maybe-quote value)) - (setf var nil)))) - (when var - (push var vars) - (push init forms) - (when (eq let/let* 'LET*) (push-vars var))))) + (if (global-var-p var) + (cmpwarn "Found :READ-ONLY declaration for global var ~A" + name) + (setf (var-type var) (c1form-primary-type init))) + (multiple-value-bind (constantp value) + (c1form-constant-p init) + (when constantp + (cmp-env-register-symbol-macro name (si::maybe-quote value)) + (setf var nil)))) + (when var + (push var vars) + (push init forms) + (when (eq let/let* 'LET*) (push-vars var))))) (setf vars (nreverse vars) forms (nreverse forms)) (when (eq let/let* 'LET) @@ -165,7 +165,7 @@ ;; - v2 is a read only variable ;; - the value of e2 is not modified in e3 nor in following expressions (when (and (eq (c1form-name form) 'LOCATION) - (loc-in-c1form-movable-p (c1form-arg 0 form))) + (loc-in-c1form-movable-p (c1form-arg 0 form))) (cmpdebug "Replacing variable ~A by its value ~A" (var-name var) form) (nsubst-var var form) t)) @@ -177,7 +177,7 @@ (when (eq (c1form-name form) 'VAR) (let ((other-var (c1form-arg 0 form))) (unless (or (global-var-p other-var) - (member other-var rest-vars) + (member other-var rest-vars) (var-changed-in-form-list other-var rest-forms)) (cmpdebug "Replacing variable ~A by its value ~A" (var-name var) form) (nsubst-var var form) @@ -185,19 +185,19 @@ (defun c2let-replaceable-var-ref-p (var form rest-forms) (when (and (eq (c1form-name form) 'VAR) - (null (var-set-nodes var)) - (local var)) + (null (var-set-nodes var)) + (local var)) (let ((var1 (c1form-arg 0 form))) (declare (type var var1)) (when (and ;; Fixme! We should be able to replace variable - ;; even if they are referenced across functions. - ;; We just need to keep track of their uses. - (local var1) - (eq (unboxed var) (unboxed var1)) - (not (var-changed-in-form-list var1 rest-forms))) - (cmpdebug "Replacing variable ~a by its value" (var-name var)) - (nsubst-var var form) - t)))) + ;; even if they are referenced across functions. + ;; We just need to keep track of their uses. + (local var1) + (eq (unboxed var) (unboxed var1)) + (not (var-changed-in-form-list var1 rest-forms))) + (cmpdebug "Replacing variable ~a by its value" (var-name var)) + (nsubst-var var form) + t)))) (defun c1let-can-move-variable-value-p (var form rest-vars rest-forms) ;; (let ((v1 e1) (v2 e2) (v3 e3)) (expr e4 v2 e5)) @@ -221,7 +221,7 @@ (defun read-only-variable-p (v other-decls) (dolist (i other-decls nil) (when (and (eq (car i) :READ-ONLY) - (member v (rest i))) + (member v (rest i))) (return t)))) (defun env-grows (possibily) @@ -230,10 +230,10 @@ (and possibily (plusp *env*) (dolist (exit *unwind-exit*) - (case exit - (RETURN (return NIL)) - (BDS-BIND) - (t (return T)))))) + (case exit + (RETURN (return NIL)) + (BDS-BIND) + (t (return T)))))) ;; should check whether a form before var causes a side-effect ;; exactly one occurrence of var is present in forms @@ -249,12 +249,12 @@ :format-arguments (list (var-name var) *current-form*)))) (defun c2let* (c1form vars forms body - &aux - (*volatile* (c1form-volatile* c1form)) - (*unwind-exit* *unwind-exit*) - (*env* *env*) - (*env-lvl* *env-lvl*) - (*inline-blocks* 0)) + &aux + (*volatile* (c1form-volatile* c1form)) + (*unwind-exit* *unwind-exit*) + (*env* *env*) + (*env-lvl* *env-lvl*) + (*inline-blocks* 0)) ;; Replace read-only variables when it is worth doing it. (loop for var in vars for rest-forms on (append forms (list body)) @@ -268,9 +268,9 @@ (loop for var in vars for kind = (local var) do (when kind - (maybe-open-inline-block) - (bind (next-lcl (var-name var)) var) - (wt-nl *volatile* (rep-type->c-name kind) " " var ";"))) + (maybe-open-inline-block) + (bind (next-lcl (var-name var)) var) + (wt-nl *volatile* (rep-type->c-name kind) " " var ";"))) ;; Create closure bindings for closed-over variables (when (some #'var-ref-ccb vars) @@ -282,15 +282,15 @@ (loop for form in forms for var in vars do (case (var-kind var) - ((LEXICAL CLOSURE SPECIAL GLOBAL) - (case (c1form-name form) - (LOCATION (bind (c1form-arg 0 form) var)) - (VAR (bind (c1form-arg 0 form) var)) - (t (bind-init form var)))) - (t ; local var - (let ((*destination* var)) ; nil (ccb) - (c2expr* form))))) - + ((LEXICAL CLOSURE SPECIAL GLOBAL) + (case (c1form-name form) + (LOCATION (bind (c1form-arg 0 form) var)) + (VAR (bind (c1form-arg 0 form) var)) + (t (bind-init form var)))) + (t ; local var + (let ((*destination* var)) ; nil (ccb) + (c2expr* form))))) + ;; Optionally register the variables with the IHS frame for debugging (if (policy-debug-variable-bindings) (let ((*unwind-exit* *unwind-exit*)) @@ -306,18 +306,18 @@ (defun discarded (var form body &aux last) (labels ((last-form (x &aux (args (c1form-args x))) - (case (c1form-name x) - (PROGN - (last-form (car (last (first args))))) - ((LET LET* FLET LABELS BLOCK CATCH) - (last-form (car (last args)))) - (VAR (c1form-arg 0 x)) - (t x)))) + (case (c1form-name x) + (PROGN + (last-form (car (last (first args))))) + ((LET LET* FLET LABELS BLOCK CATCH) + (last-form (car (last args)))) + (VAR (c1form-arg 0 x)) + (t x)))) (and (not (form-causes-side-effect form)) - (or (< (var-ref var) 1) - (and (= (var-ref var) 1) - (eq var (last-form body)) - (eq 'TRASH *destination*)))))) + (or (< (var-ref var) 1) + (and (= (var-ref var) 1) + (eq var (last-form body)) + (eq 'TRASH *destination*)))))) (defun nsubst-var (var form) (when (var-set-nodes var) @@ -335,8 +335,8 @@ (defun member-var (var list) (let ((kind (var-kind var))) (if (member kind '(SPECIAL GLOBAL)) - (member var list :test - #'(lambda (v1 v2) - (and (member (var-kind v2) '(SPECIAL GLOBAL)) - (eql (var-name v1) (var-name v2))))) - (member var list)))) + (member var list :test + #'(lambda (v1 v2) + (and (member (var-kind v2) '(SPECIAL GLOBAL)) + (eql (var-name v1) (var-name v2))))) + (member var list)))) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index d8d53d709..388cc6f94 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -15,49 +15,49 @@ (in-package "COMPILER") ;;; Valid locations are: -;;; NIL -;;; T -;;; fixnum -;;; VALUE0 -;;; VALUES -;;; var-object +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; var-object ;;; a string designating a C expression -;;; ( VALUE i ) VALUES(i) -;;; ( VV vv-index ) -;;; ( VV-temp vv-index ) -;;; ( LCL lcl [representation-type]) local variable, type unboxed -;;; ( TEMP temp ) local variable, type object -;;; ( FRAME ndx ) variable in local frame stack -;;; ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed -;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function -;;; ( C-INLINE output-type fun/string locs side-effects output-var ) -;;; ( COERCE-LOC representation-type location) -;;; ( FDEFINITION vv-index ) -;;; ( MAKE-CCLOSURE cfun ) -;;; ( FIXNUM-VALUE fixnum-value ) -;;; ( CHARACTER-VALUE character-code ) -;;; ( LONG-FLOAT-VALUE long-float-value vv ) -;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) -;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) -;;; ( STACK-POINTER index ) retrieve a value from the stack -;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-type]) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( FRAME ndx ) variable in local frame stack +;;; ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed +;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function +;;; ( C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) ;;; ( THE type location ) -;;; ( KEYVARS n ) -;;; VA-ARG -;;; CL-VA-ARG +;;; ( KEYVARS n ) +;;; VA-ARG +;;; CL-VA-ARG ;;; Valid *DESTINATION* locations are: ;;; -;;; VALUE0 -;;; RETURN Object returned from current function. -;;; TRASH Value may be thrown away. -;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) (defun tmp-destination (loc) (case loc @@ -73,28 +73,28 @@ (defun loc-in-c1form-movable-p (loc) "A location that is in a C1FORM and can be moved" (cond ((member loc '(t nil)) - t) - ((numberp loc) - t) - ((stringp loc) - t) + t) + ((numberp loc) + t) + ((stringp loc) + t) ((vv-p loc) t) - ((member loc '(value0 values va-arg cl-va-arg)) - nil) - ((atom loc) - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))) - ((eq (first loc) 'THE) - (loc-in-c1form-movable-p (third loc))) - ((member (setf loc (car loc)) - '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE - DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE #+long-float LONG-FLOAT-VALUE - KEYVARS)) - t) - (t - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))))) + ((member loc '(value0 values va-arg cl-va-arg)) + nil) + ((atom loc) + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))) + ((eq (first loc) 'THE) + (loc-in-c1form-movable-p (third loc))) + ((member (setf loc (car loc)) + '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE + DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE #+long-float LONG-FLOAT-VALUE + KEYVARS)) + t) + (t + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))))) (defun uses-values (loc) (and (consp loc) @@ -116,14 +116,14 @@ (values t value)))) ((atom loc) (values nil nil)) - ((eq (first loc) 'THE) - (loc-immediate-value-p (third loc))) + ((eq (first loc) 'THE) + (loc-immediate-value-p (third loc))) ((member (first loc) '(fixnum-value long-float-value double-float-value single-float-value)) (values t (second loc))) - ((eq (first loc) 'character-value) - (values t (code-char (second loc)))) + ((eq (first loc) 'character-value) + (values t (code-char (second loc)))) (t (values nil nil)))) @@ -145,8 +145,8 @@ (when (eq txt :not-found) (unknown-location 'wt-loc loc)) (wt txt))) - ((stringp loc) - (wt loc)) + ((stringp loc) + (wt loc)) ((var-p loc) (wt-var loc)) ((vv-p loc) @@ -188,16 +188,16 @@ (defun loc-refers-to-special (loc) (cond ((var-p loc) - (member (var-kind loc) '(SPECIAL GLOBAL))) - ((atom loc) - nil) - ((eq (first loc) 'THE) - (loc-refers-to-special (third loc))) - ((eq (setf loc (first loc)) 'BIND) - t) - ((eq loc 'C-INLINE) - t) ; We do not know, so guess yes - (t nil))) + (member (var-kind loc) '(SPECIAL GLOBAL))) + ((atom loc) + nil) + ((eq (first loc) 'THE) + (loc-refers-to-special (third loc))) + ((eq (setf loc (first loc)) 'BIND) + t) + ((eq loc 'C-INLINE) + t) ; We do not know, so guess yes + (t nil))) (defun values-loc (n) (list 'VALUE n)) @@ -242,8 +242,8 @@ (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";")) (t (wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) - (wt ";") - (wt-nl "cl_env_copy->nvalues = 1;")))) + (wt ";") + (wt-nl "cl_env_copy->nvalues = 1;")))) (defun set-value0-loc (loc) (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")) @@ -260,20 +260,20 @@ (defun loc-with-side-effects-p (loc &aux name) (cond ((var-p loc) - (and (global-var-p loc) - (policy-global-var-checking))) - ((atom loc) - nil) - ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) - :test #'eq) - t) - ((eq name 'THE) - (loc-with-side-effects-p (third loc))) - ((eq name 'FDEFINITION) - (policy-global-function-checking)) - ((eq name 'C-INLINE) - (or (eq (sixth loc) 'VALUES) ;; Uses VALUES - (fifth loc))))) ;; or side effects + (and (global-var-p loc) + (policy-global-var-checking))) + ((atom loc) + nil) + ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) + :test #'eq) + t) + ((eq name 'THE) + (loc-with-side-effects-p (third loc))) + ((eq name 'FDEFINITION) + (policy-global-function-checking)) + ((eq name 'C-INLINE) + (or (eq (sixth loc) 'VALUES) ;; Uses VALUES + (fifth loc))))) ;; or side effects (defun set-trash-loc (loc) (when (loc-with-side-effects-p loc) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index abfc43ec9..e418b9439 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -26,7 +26,7 @@ (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) + (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) (defun ,reset-name () (make-array 1024 :element-type t :adjustable nil)) (defun ,name ,lambda-list @@ -81,21 +81,21 @@ (defmacro with-exit-label ((label) &body body) `(let* ((,label (next-label)) - (*unwind-exit* (cons ,label *unwind-exit*))) + (*unwind-exit* (cons ,label *unwind-exit*))) ,@body (wt-label ,label))) (defmacro with-optional-exit-label ((label) &body body) `(let* ((,label (maybe-next-label)) - (*unwind-exit* (adjoin ,label *unwind-exit*))) + (*unwind-exit* (adjoin ,label *unwind-exit*))) ,@body (maybe-wt-label ,label))) (defun next-lcl (&optional name) (list 'LCL (incf *lcl*) T - (if (and name (symbol-package name)) - (lisp-to-c-name name) - ""))) + (if (and name (symbol-package name)) + (lisp-to-c-name name) + ""))) (defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) (let ((code (incf *next-cfun*))) @@ -112,8 +112,8 @@ (setq *max-lex* (max *lex* *max-lex*)))) (defun next-env () (prog1 *env* - (incf *env*) - (setq *max-env* (max *env* *max-env*)))) + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) (defmacro reckless (&rest body) `(locally (declare (optimize (safety 0))) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index e0b6b597e..3df99c759 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -36,7 +36,7 @@ (progn (delete-file base) (setf base nil))))) (unless base (error "Unable to create temporay file~%~ - ~AXXXXXX + ~AXXXXXX Make sure you have enough free space in disk, check permissions or set~%~ the environment variable TMPDIR to a different value." template)) base)) @@ -62,49 +62,49 @@ the environment variable TMPDIR to a different value." template)) (:import-library (setf extension "implib")) ((:fasl :fas) (setf extension "fas"))) (cond ((not (member output-file '(T NIL))) - output-file) - (format - (merge-pathnames (format nil format (pathname-name name)) name)) - (t - (make-pathname :type extension :defaults name))))) + output-file) + (format + (merge-pathnames (format nil format (pathname-name name)) name)) + (t + (make-pathname :type extension :defaults name))))) #+msvc (defun delete-msvc-generated-files (output-pathname) (loop for i in '("implib" "exp" "ilk" "pdb") - for full = (make-pathname :type i :defaults output-pathname) - for truename = (probe-file full) - when truename - do (cmp-delete-file truename))) + for full = (make-pathname :type i :defaults output-pathname) + for truename = (probe-file full) + when truename + do (cmp-delete-file truename))) #+msvc (defun embed-manifest-file (o-file &optional (type :dll)) (let* ((real-file (probe-file o-file))) (when real-file (let* ((manifest-namestring (concatenate 'string (namestring o-file) - ".manifest")) + ".manifest")) (resource-code (ecase type ((:dll :shared-library :fasl :fas) 2) ((:program) 1))) (resource-option (format nil "-outputresource:~A;~D" (namestring real-file) resource-code)) - (manifest (probe-file manifest-namestring))) - (when manifest - (safe-run-program "mt" + (manifest (probe-file manifest-namestring))) + (when manifest + (safe-run-program "mt" (list "-nologo" "-manifest" manifest-namestring resource-option)) - (delete-file manifest)))))) + (delete-file manifest)))))) (defun cmp-delete-file (file) (cond ((null *delete-files*)) - ((ext:getenv "ECL_PRESERVE_FILES")) + ((ext:getenv "ECL_PRESERVE_FILES")) ((null (probe-file file))) - (*debug-compiler* - (cmpprogress "~%Postponing deletion of ~A" file) + (*debug-compiler* + (cmpprogress "~%Postponing deletion of ~A" file) (push file *files-to-be-deleted*)) - (t + (t (delete-file file)))) (push #'(lambda () (mapc #'delete-file *files-to-be-deleted*)) @@ -178,10 +178,10 @@ the environment variable TMPDIR to a different value." template)) ;; MSVC linker options are added at the end, after the ;; /link flag, because they are not processed by the ;; compiler, but by the linker - (append ld-flags - (list (concatenate 'string "/LIBPATH:" - (ecl-library-directory)) - (concatenate 'string "/IMPLIB:" implib))))) + (append ld-flags + (list (concatenate 'string "/LIBPATH:" + (ecl-library-directory)) + (concatenate 'string "/IMPLIB:" implib))))) #+mingw32 (setf ld-flags (list* "-shared" ld-flags)) (linker-cc o-pathname object-files :type :dll :ld-flags ld-flags))) @@ -197,12 +197,12 @@ the environment variable TMPDIR to a different value." template)) ;; /link flag, because they are not processed by the ;; compiler, but by the linker (append ld-flags - (list - ;; Not needed because we use ECL_DLLEXPORT - ;; (concatenate 'string "/EXPORT:" init-name) - (concatenate 'string "/LIBPATH:" - (ecl-library-directory)) - (concatenate 'string "/IMPLIB:" implib))))) + (list + ;; Not needed because we use ECL_DLLEXPORT + ;; (concatenate 'string "/EXPORT:" init-name) + (concatenate 'string "/LIBPATH:" + (ecl-library-directory)) + (concatenate 'string "/IMPLIB:" implib))))) #+mingw32 (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags)) (linker-cc o-pathname object-files :type :fasl :ld-flags ld-flags))) @@ -216,7 +216,7 @@ the environment variable TMPDIR to a different value." template)) #define ECL_CPP_TAG #endif -~:{ extern ECL_CPP_TAG void ~A(cl_object);~%~} +~:{ extern ECL_CPP_TAG void ~A(cl_object);~%~} ") @@ -238,33 +238,33 @@ void ~A(cl_object cblock) * structure, so that the function initializes it, and then * it is invoked with OBJNULL, to force initialization. */ - static cl_object Cblock = OBJNULL; + static cl_object Cblock = OBJNULL; if (cblock != OBJNULL) { - Cblock = cblock; + Cblock = cblock; #ifndef ECL_DYNAMIC_VV - cblock->cblock.data = NULL; + cblock->cblock.data = NULL; #endif - cblock->cblock.data_size = 0; - return; - } - ~A + cblock->cblock.data_size = 0; + return; + } + ~A { - /* + /* * At this point Cblock contains the cblock of the parent. * Notice how the modules are linked to the parent forming a * circular chain. This disables the garbage collection of * the library until _ALL_ functions in all modules are unlinked. */ - cl_object current, next = Cblock; + cl_object current, next = Cblock; ~:{ - current = ecl_make_codeblock(); - current->cblock.next = next; - next = current; - ecl_init_module(current, ~A); + current = ecl_make_codeblock(); + current->cblock.next = next; + next = current; + ecl_init_module(current, ~A); ~} - Cblock->cblock.next = current; + Cblock->cblock.next = current; } - ~A + ~A } ") @@ -272,13 +272,13 @@ void ~A(cl_object cblock) extern int main(int argc, char **argv) { - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; - si_exit(0); + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; + si_exit(0); } ") @@ -286,12 +286,12 @@ main(int argc, char **argv) extern int ~A(int argc, char **argv) { - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; } ") @@ -301,16 +301,16 @@ extern int int WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) { - char **argv; - int argc; - ecl_get_commandline_args(&argc, &argv); - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; - si_exit(0); + char **argv; + int argc; + ecl_get_commandline_args(&argc, &argv); + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; + si_exit(0); } ") @@ -318,25 +318,25 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS "Given a file name, guess whether it is an object file, a library, a program or a loadable module." (let ((record (assoc (pathname-type pathname) - '((#.+object-file-extension+ :object) + '((#.+object-file-extension+ :object) ("o" :object) ("obj" :object) ("c" :c) (#.+static-library-extension+ :static-library) - ("lib" :static-library) - ("a" :static-library) + ("lib" :static-library) + ("a" :static-library) (#.+shared-library-extension+ :shared-library) ("dylib" :shared-library) - ("dll" :shared-library) - ("so" :shared-library) - ("fas" :fasl)) - :test #'string-equal))) + ("dll" :shared-library) + ("so" :shared-library) + ("fas" :fasl)) + :test #'string-equal))) (if record - (second record) - (progn - (warn "File ~s is of no known file type. Assuming it is an object file." - pathname) - :object)))) + (second record) + (progn + (warn "File ~s is of no known file type. Assuming it is an object file." + pathname) + :object)))) (defun guess-ld-flags (pathname &key (kind (guess-kind pathname))) "Given a file name, return the compiler command line argument to link this file in." @@ -371,11 +371,11 @@ filesystem or in the database of ASDF modules." (or (existing-system-output system :library) (existing-system-output system :shared-library))) (fallback () - (translate-logical-pathname - (merge-pathnames - "SYS:" - (compile-file-pathname (string-downcase library) - :type :library))))) + (translate-logical-pathname + (merge-pathnames + "SYS:" + (compile-file-pathname (string-downcase library) + :type :library))))) (or #-ecl-min (and asdf @@ -384,21 +384,21 @@ filesystem or in the database of ASDF modules." (fallback))))) (defun builder (target output-name &key lisp-files ld-flags - (init-name nil) + (init-name nil) (main-name nil) - (prologue-code "") - (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T))) - #+:win32 (system :console) - &aux - (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*)))) + (prologue-code "") + (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T))) + #+:win32 (system :console) + &aux + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*)))) ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) ;; ;; The epilogue-code can be either a string made of C code, or a @@ -407,37 +407,37 @@ filesystem or in the database of ASDF modules." ;; to avoid using the compiler. ;; (cond ((null epilogue-code) - (setf epilogue-code "")) - ((stringp epilogue-code) - ) - (t - (with-standard-io-syntax - (setq epilogue-code - (with-output-to-string (stream) - (princ "{ const char *lisp_code = " stream) - (wt-filtered-data (write-to-string epilogue-code) stream) - (princ "; + (setf epilogue-code "")) + ((stringp epilogue-code) + ) + (t + (with-standard-io-syntax + (setq epilogue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string epilogue-code) stream) + (princ "; cl_object output; si_select_package(ecl_make_simple_base_string(\"CL-USER\", 7)); output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); }" stream) - ))))) + ))))) (cond ((null prologue-code) - (setf prologue-code "")) - ((stringp prologue-code) - ) - (t - (with-standard-io-syntax - (setq prologue-code - (with-output-to-string (stream) - (princ "{ const char *lisp_code = " stream) - (wt-filtered-data (write-to-string prologue-code) stream) - (princ "; + (setf prologue-code "")) + ((stringp prologue-code) + ) + (t + (with-standard-io-syntax + (setq prologue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string prologue-code) stream) + (princ "; cl_object output; si_select_package(ecl_make_simple_base_string(\"CL-USER\", 7)); output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); }" stream) - ))))) + ))))) ;; ;; When a module is built out of several object files, we have to ;; create an additional object file that initializes those ones. @@ -448,27 +448,27 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); ;; (let* ((tmp-names (safe-mkstemp #P"TMP:ECLINIT")) (tmp-name (first tmp-names)) - (c-name (si::coerce-to-filename - (compile-file-pathname tmp-name :type :c))) - (o-name (si::coerce-to-filename - (compile-file-pathname tmp-name :type :object))) - submodules + (c-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :c))) + (o-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :object))) + submodules (submodules-data ()) - c-file) + c-file) (dolist (item (reverse lisp-files)) (let* ((path (etypecase item - (symbol (system-ld-flag item)) - (pathname item) - (string (parse-namestring item)))) - (kind (guess-kind path))) - (unless (member kind '(:shared-library :dll :static-library :lib - :object :c)) - (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) - (let* ((init-fn (guess-init-name path (guess-kind path))) - (flags (guess-ld-flags path))) - ;; We should give a warning that we cannot link this module in - (when flags (push flags ld-flags)) - (push (list init-fn path) submodules)))) + (symbol (system-ld-flag item)) + (pathname item) + (string (parse-namestring item)))) + (kind (guess-kind path))) + (unless (member kind '(:shared-library :dll :static-library :lib + :object :c)) + (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) + (let* ((init-fn (guess-init-name path (guess-kind path))) + (flags (guess-ld-flags path))) + ;; We should give a warning that we cannot link this module in + (when flags (push flags ld-flags)) + (push (list init-fn path) submodules)))) (setf submodules-data (apply #'concatenate '(array base-char (*)) submodules-data)) (setq c-file (open c-name :direction :output :external-format :default)) @@ -483,15 +483,15 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); (:program (format c-file +lisp-program-init+ init-name "" submodules "") (format c-file #+:win32 (ecase system (:console +lisp-program-main+) - (:windows +lisp-program-winmain+)) - #-:win32 +lisp-program-main+ + (:windows +lisp-program-winmain+)) + #-:win32 +lisp-program-main+ prologue-code init-name epilogue-code) (close c-file) (compiler-cc c-name o-name) (linker-cc output-name (list* (namestring o-name) ld-flags))) ((:library :static-library :lib) (format c-file +lisp-program-init+ init-name prologue-code - submodules epilogue-code) + submodules epilogue-code) (cmpnote "Library initialization function is ~A" main-name) (format c-file +lisp-library-main+ main-name prologue-code init-name epilogue-code) @@ -502,7 +502,7 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); #+dlopen ((:shared-library :dll) (format c-file +lisp-program-init+ init-name prologue-code - submodules epilogue-code) + submodules epilogue-code) (cmpnote "Library initialization function is ~A" main-name) (format c-file +lisp-library-main+ main-name prologue-code init-name epilogue-code) @@ -512,7 +512,7 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); #+dlopen (:fasl (format c-file +lisp-program-init+ init-name prologue-code - submodules epilogue-code) + submodules epilogue-code) (close c-file) (compiler-cc c-name o-name) (bundle-cc output-name init-name (list* o-name ld-flags)))) @@ -538,29 +538,29 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); (defun compile-file (input-pathname &rest args &key - ((:verbose *compile-verbose*) *compile-verbose*) - ((:print *compile-print*) *compile-print*) + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) (source-truename nil) (source-offset 0) - (c-file nil) - (h-file nil) - (data-file nil) - (system-p nil) - (load nil) + (c-file nil) + (h-file nil) + (data-file nil) + (system-p nil) + (load nil) (external-format :default) - output-file + output-file &aux (*standard-output* *standard-output*) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*package* *package*) - (*print-pretty* nil) - (*compile-file-pathname* nil) - (*compile-file-truename* nil) + (*print-pretty* nil) + (*compile-file-pathname* nil) + (*compile-file-truename* nil) (ext:*source-location* (cons source-truename 0)) - (*suppress-compiler-messages* - (or *suppress-compiler-messages* (not *compile-verbose*))) - input-file - init-name) + (*suppress-compiler-messages* + (or *suppress-compiler-messages* (not *compile-verbose*))) + input-file + init-name) (declare (notinline compiler-cc)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, @@ -572,10 +572,10 @@ compiled successfully, returns the pathname of the compiled file" ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) #-dlopen (unless system-p @@ -587,12 +587,12 @@ compiled successfully, returns the pathname of the compiled file" (setq *compile-file-pathname* (pathname (merge-pathnames input-pathname))) (unless (probe-file *compile-file-pathname*) (if (pathname-type input-pathname) - (error 'file-error :pathname input-pathname) - (dolist (ext '("lsp" "LSP" "lisp" "LISP") - (error 'file-error :pathname input-pathname)) - (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) - (when (probe-file *compile-file-pathname*) - (return))))) + (error 'file-error :pathname input-pathname) + (dolist (ext '("lsp" "LSP" "lisp" "LISP") + (error 'file-error :pathname input-pathname)) + (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) + (when (probe-file *compile-file-pathname*) + (return))))) (setq input-file (truename *compile-file-pathname*) *compile-file-truename* input-file) @@ -602,8 +602,8 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname)) (let* ((eof '(NIL)) - (*compiler-in-use* *compiler-in-use*) - (*load-time-values* nil) ;; Load time values are compiled + (*compiler-in-use* *compiler-in-use*) + (*load-time-values* nil) ;; Load time values are compiled (output-file (apply #'compile-file-pathname input-file args)) (true-output-file nil) ;; Will be set at the end (c-pathname (apply #'compile-file-pathname output-file :output-file c-file @@ -612,7 +612,7 @@ compiled successfully, returns the pathname of the compiled file" :type :h args)) (data-pathname (apply #'compile-file-pathname output-file :output-file data-file :type :data args)) - (compiler-conditions nil) + (compiler-conditions nil) (to-delete (nconc (unless c-file (list c-pathname)) (unless h-file (list h-pathname)) (unless data-file (list data-pathname))))) @@ -622,7 +622,7 @@ compiled successfully, returns the pathname of the compiled file" (print-compiler-info) (when (probe-file "./cmpinit.lsp") - (load "./cmpinit.lsp" :verbose *compile-verbose*)) + (load "./cmpinit.lsp" :verbose *compile-verbose*)) (data-init) @@ -641,7 +641,7 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;; End of Pass 1.") (setf init-name (compute-init-name output-file :kind - (if system-p :object :fasl))) + (if system-p :object :fasl))) (compiler-pass2 c-pathname h-pathname data-pathname init-name :input-designator (namestring input-pathname)) @@ -666,7 +666,7 @@ compiled successfully, returns the pathname of the compiled file" (mapc #'cmp-delete-file to-delete) (when (and load true-output-file (not system-p)) - (load true-output-file :verbose *compile-verbose*)) + (load true-output-file :verbose *compile-verbose*)) ) ; with-compiler-env @@ -677,9 +677,9 @@ compiled successfully, returns the pathname of the compiled file" with warning-p = nil with failure-p = nil do (cond ((typep i 'style-warning) - (setf warning-p t)) - ((typep i '(or compiler-error warning)) - (setf warning-p t failure-p t))) + (setf warning-p t)) + ((typep i '(or compiler-error warning)) + (setf warning-p t failure-p t))) finally (return (values main-value warning-p failure-p)))) #-dlopen @@ -696,14 +696,14 @@ compiled successfully, returns the pathname of the compiled file" (defun compile (name &optional (def nil supplied-p) &aux form data-pathname (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*))) + (not *compile-verbose*))) (*compiler-in-use* *compiler-in-use*) (*standard-output* *standard-output*) (*error-output* *error-output*) (*package* *package*) (*compile-print* nil) - (*print-pretty* nil) - (*compiler-constants* t)) + (*print-pretty* nil) + (*compiler-constants* t)) "Args: (name &optional definition) If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. @@ -721,40 +721,40 @@ after compilation." ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) (cond ((and supplied-p def) - (when (functionp def) - (unless (function-lambda-expression def) - (return-from compile def)) - (setf def (function-lambda-expression def))) + (when (functionp def) + (unless (function-lambda-expression def) + (return-from compile def)) + (setf def (function-lambda-expression def))) (setq form (if name `(setf (symbol-function ',name) #',def) `(set 'GAZONK #',def)))) - ((not (fboundp name)) - (error "Symbol ~s is unbound." name)) - ((typep (setf def (symbol-function name)) 'standard-generic-function) - (warn "COMPILE can not compile generic functions yet") - (return-from compile (values def t nil))) - ((null (setq form (function-lambda-expression def))) - (warn "We have lost the original function definition for ~s. Compilation to C failed" + ((not (fboundp name)) + (error "Symbol ~s is unbound." name)) + ((typep (setf def (symbol-function name)) 'standard-generic-function) + (warn "COMPILE can not compile generic functions yet") + (return-from compile (values def t nil))) + ((null (setq form (function-lambda-expression def))) + (warn "We have lost the original function definition for ~s. Compilation to C failed" name) - (return-from compile (values def t nil))) - (t - (setq form `(setf (symbol-function ',name) #',form)))) + (return-from compile (values def t nil))) + (t + (setq form `(setf (symbol-function ',name) #',form)))) (let*((*load-time-values* 'values) ;; Only the value is kept (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) - (compiler-conditions nil)) + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil)) (with-compiler-env (compiler-conditions) (print-compiler-info) @@ -762,29 +762,29 @@ after compilation." (t1expr form) (cmpprogress "~&;;; End of Pass 1.") (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) - (compiler-pass2 c-pathname h-pathname data-pathname init-name + (compiler-pass2 c-pathname h-pathname data-pathname init-name :input-designator (let* ((*print-circle* t) - (*print-length* 8) - (*print-depth* 4)) - (format nil "~W" def)))) + (*print-length* 8) + (*print-depth* 4)) + (format nil "~W" def)))) (data-c-dump data-pathname) (compiler-cc c-pathname o-pathname) (bundle-cc (si::coerce-to-filename so-pathname) - init-name - (list (si::coerce-to-filename o-pathname))) + init-name + (list (si::coerce-to-filename o-pathname))) (cmp-delete-file c-pathname) (cmp-delete-file h-pathname) (cmp-delete-file o-pathname) (mapc 'cmp-delete-file tmp-names) (cond ((probe-file so-pathname) - (load so-pathname :verbose nil) - (cmp-delete-file so-pathname)) - (t - (setf name nil) - (set 'GAZONK nil) - (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) + (load so-pathname :verbose nil) + (cmp-delete-file so-pathname)) + (t + (setf name nil) + (set 'GAZONK nil) + (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) ) ; with-compiler-env (cmp-delete-file c-pathname) (cmp-delete-file h-pathname) @@ -798,9 +798,9 @@ after compilation." (compiler-output-values output compiler-conditions)))) (defun disassemble (thing &key (h-file nil) (data-file nil) - &aux def disassembled-form - (*compiler-in-use* *compiler-in-use*) - (*print-pretty* nil)) + &aux def disassembled-form + (*compiler-in-use* *compiler-in-use*) + (*print-pretty* nil)) "Compiles the form specified by THING and prints the intermediate C language code for that form. But does not install the result of compilation. If THING is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd. If THING is @@ -812,56 +812,56 @@ from the C language code. NIL means \"do not create the file\"." (when (si::valid-function-name-p thing) (setq thing (fdefinition thing))) (cond ((null thing)) - ((functionp thing) - (unless (si::bc-disassemble thing) - (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) - (return-from disassemble nil))) - ((atom thing) - (error 'simple-type-error - :datum thing - :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" - :format-arguments (list thing))) - ((eq (car thing) 'LAMBDA) - (setq disassembled-form `(defun gazonk ,@(cdr thing)))) - ((eq (car thing) 'EXT:LAMBDA-BLOCK) - (setq disassembled-form `(defun ,@(rest thing)))) - (t - (error 'simple-type-error - :datum thing - :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" - :format-arguments (list thing)))) + ((functionp thing) + (unless (si::bc-disassemble thing) + (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) + (return-from disassemble nil))) + ((atom thing) + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing))) + ((eq (car thing) 'LAMBDA) + (setq disassembled-form `(defun gazonk ,@(cdr thing)))) + ((eq (car thing) 'EXT:LAMBDA-BLOCK) + (setq disassembled-form `(defun ,@(rest thing)))) + (t + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing)))) (let* ((null-stream (make-broadcast-stream)) (*compiler-output1* null-stream) (*compiler-output2* (if h-file - (open h-file :direction :output :external-format :default) - null-stream)) + (open h-file :direction :output :external-format :default) + null-stream)) (t3local-fun (symbol-function 'T3LOCAL-FUN)) - (compiler-conditions nil)) + (compiler-conditions nil)) (with-compiler-env (compiler-conditions) (unwind-protect - (progn - (setf (symbol-function 'T3LOCAL-FUN) - #'(lambda (&rest args) - (let ((*compiler-output1* *standard-output*)) - (apply t3local-fun args)))) - (data-init) - (t1expr disassembled-form) - (ctop-write (compute-init-name "foo" :kind :fasl) - (if h-file h-file "") - (if data-file data-file "")) - (when data-file + (progn + (setf (symbol-function 'T3LOCAL-FUN) + #'(lambda (&rest args) + (let ((*compiler-output1* *standard-output*)) + (apply t3local-fun args)))) + (data-init) + (t1expr disassembled-form) + (ctop-write (compute-init-name "foo" :kind :fasl) + (if h-file h-file "") + (if data-file data-file "")) + (when data-file (data-c-dump data-file))) - (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) - (when h-file (close *compiler-output2*))))) + (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) + (when h-file (close *compiler-output2*))))) nil) (defun compiler-pass2 (c-pathname h-pathname data-pathname init-name - &key input-designator) + &key input-designator) (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create :if-exists :supersede) (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) #-ecl-min (multiple-value-bind (second minute hour day month year) @@ -871,7 +871,7 @@ from the C language code. NIL means \"do not create the file\"." (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) (wt-comment-nl "Source: ~A" input-designator) (with-open-file (*compiler-output2* h-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create :if-exists :supersede) (wt-nl1 "#include " *cmpinclude*) (ctop-write init-name h-pathname data-pathname) (terpri *compiler-output1*) @@ -880,23 +880,23 @@ from the C language code. NIL means \"do not create the file\"." (defun ecl-include-directory () "Finds the directory in which the header files were installed." (cond ((and *ecl-include-directory* - (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) - *ecl-include-directory*) - ((probe-file "SYS:ecl;config.h") - (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find include directory")))) + (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) + *ecl-include-directory*) + ((probe-file "SYS:ecl;config.h") + (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find include directory")))) (defun ecl-library-directory () "Finds the directory in which the ECL core library was installed." (cond ((and *ecl-library-directory* - (probe-file (merge-pathnames (compile-file-pathname "ecl" :type - #+dlopen :shared-library - #-dlopen :static-library) - *ecl-library-directory*))) - *ecl-library-directory*) - ((probe-file "SYS:BUILD-STAMP") - (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find library directory")))) + (probe-file (merge-pathnames (compile-file-pathname "ecl" :type + #+dlopen :shared-library + #-dlopen :static-library) + *ecl-library-directory*))) + *ecl-library-directory*) + ((probe-file "SYS:BUILD-STAMP") + (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find library directory")))) (defun compiler-cc (c-pathname o-pathname) (safe-run-program @@ -915,16 +915,16 @@ from the C language code. NIL means \"do not create the file\"." ,@(split-program-options *user-cc-flags*)))) ; Since the SUN4 assembler loops with big files, you might want to use this: ; (format nil -; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" -; *cc* (>= *speed* 2) +; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" +; *cc* (>= *speed* 2) ; *include-directory* -; (namestring c-pathname) -; (namestring o-pathname) -; (namestring s-pathname)) +; (namestring c-pathname) +; (namestring o-pathname) +; (namestring s-pathname)) (defun print-compiler-info () (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%" - *safety* *space* *speed* *debug*)) + *safety* *space* *speed* *debug*)) (defmacro with-compilation-unit (options &rest body) `(progn ,@body)) @@ -941,9 +941,9 @@ from the C language code. NIL means \"do not create the file\"." (ext::package-lock (find-package :cl) nil) (setf *features* (delete :ecl-bytecmp *features*)) (setf (fdefinition 'disassemble) disassemble - (fdefinition 'compile) compile - (fdefinition 'compile-file) #'compile-file - (fdefinition 'compile-file-pathname) #'compile-file-pathname) + (fdefinition 'compile) compile + (fdefinition 'compile-file) #'compile-file + (fdefinition 'compile-file-pathname) #'compile-file-pathname) (ext::package-lock (find-package :cl) t))) (provide 'cmp) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index db8194cc9..c08bb2ffd 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -22,38 +22,38 @@ (let ((which (first whole))) (when (eq which 'FUNCALL) (setf whole (rest whole) - which (first whole)) + which (first whole)) (when (consp which) - (if (eq (first which) 'FUNCTION) - (setf which (second which)) - (return-from expand-mapcar whole)))) + (if (eq (first which) 'FUNCTION) + (setf which (second which)) + (return-from expand-mapcar whole)))) (let* ((function (second whole)) - (args (cddr whole)) - iterators for-statements - (in-or-on :IN) - (do-or-collect :COLLECT) - (list-1-form nil) - (finally-form nil)) + (args (cddr whole)) + iterators for-statements + (in-or-on :IN) + (do-or-collect :COLLECT) + (list-1-form nil) + (finally-form nil)) (case which - (MAPCAR) - (MAPLIST (setf in-or-on :ON)) - (MAPC (setf do-or-collect :DO)) - (MAPL (setf in-or-on :ON do-or-collect :DO)) - (MAPCAN (setf do-or-collect 'NCONC)) - (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) + (MAPCAR) + (MAPLIST (setf in-or-on :ON)) + (MAPC (setf do-or-collect :DO)) + (MAPL (setf in-or-on :ON do-or-collect :DO)) + (MAPCAN (setf do-or-collect 'NCONC)) + (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) (when (eq do-or-collect :DO) - (let ((var (gensym))) - (setf list-1-form `(with ,var = ,(first args)) - args (list* var (rest args)) - finally-form `(finally (return ,var))))) + (let ((var (gensym))) + (setf list-1-form `(with ,var = ,(first args)) + args (list* var (rest args)) + finally-form `(finally (return ,var))))) (loop for arg in (reverse args) - do (let ((var (gensym))) - (setf iterators (cons var iterators) - for-statements (list* :for var in-or-on arg for-statements)))) + do (let ((var (gensym))) + (setf iterators (cons var iterators) + for-statements (list* :for var in-or-on arg for-statements)))) `(loop ,@list-1-form - ,@for-statements - ,do-or-collect (funcall ,function ,@iterators) - ,@finally-form)))) + ,@for-statements + ,do-or-collect (funcall ,function ,@iterators) + ,@finally-form)))) (define-compiler-macro mapcar (&whole whole &rest r) (expand-mapcar whole)) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 8271a3f20..47a65ad86 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -25,18 +25,18 @@ (c1funcall args)) ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) ((and (= (length args) 2) - (consp (setq forms (second args))) - (eq 'VALUES (first forms))) + (consp (setq forms (second args))) + (eq 'VALUES (first forms))) (c1funcall (list* (first args) (rest forms)))) ;; More complicated case. (t (let ((function (gensym)) - (frame (gensym))) + (frame (gensym))) `(with-stack ,frame - (let* ((,function ,(first args))) - ,@(loop for i in (rest args) - collect `(stack-push-values ,frame ,i)) - (si::apply-from-stack-frame ,frame ,function))))))) + (let* ((,function ,(first args))) + ,@(loop for i in (rest args) + collect `(stack-push-values ,frame ,i)) + (si::apply-from-stack-frame ,frame ,function))))))) (defun c1multiple-value-prog1 (args) (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) @@ -82,15 +82,15 @@ ;; of a function. ((endp forms) (cond ((eq *destination* 'RETURN) - (wt-nl "value0 = ECL_NIL;") - (wt-nl "cl_env_copy->nvalues = 0;") - (unwind-exit 'RETURN)) - ((eq *destination* 'VALUES) - (wt-nl "cl_env_copy->values[0] = ECL_NIL;") - (wt-nl "cl_env_copy->nvalues = 0;") - (unwind-exit 'VALUES)) - (t - (unwind-exit 'NIL)))) + (wt-nl "value0 = ECL_NIL;") + (wt-nl "cl_env_copy->nvalues = 0;") + (unwind-exit 'RETURN)) + ((eq *destination* 'VALUES) + (wt-nl "cl_env_copy->values[0] = ECL_NIL;") + (wt-nl "cl_env_copy->nvalues = 0;") + (unwind-exit 'VALUES)) + (t + (unwind-exit 'NIL)))) ;; For a single form, we must simply ensure that we only take a single ;; value of those that the function may output. ((endp (rest forms)) @@ -105,60 +105,60 @@ ;; and force the compiler to retrieve anything out of it. (t (let* ((nv (length forms)) - (*inline-blocks* 0) + (*inline-blocks* 0) (*temp* *temp*) - (forms (nreverse (coerce-locs (inline-args forms))))) + (forms (nreverse (coerce-locs (inline-args forms))))) ;; By inlining arguments we make sure that VL has no call to funct. ;; Reverse args to avoid clobbering VALUES(0) (wt-nl "cl_env_copy->nvalues = " nv ";") (do ((vl forms (rest vl)) - (i (1- (length forms)) (1- i))) - ((null vl)) - (declare (fixnum i)) - (wt-nl "cl_env_copy->values[" i "] = " (first vl) ";")) + (i (1- (length forms)) (1- i))) + ((null vl)) + (declare (fixnum i)) + (wt-nl "cl_env_copy->values[" i "] = " (first vl) ";")) (unwind-exit 'VALUES) (close-inline-blocks))))) (defun c1multiple-value-setq (args &aux (vars nil) (temp-vars nil) - (late-bindings nil)) + (late-bindings nil)) (check-args-number 'MULTIPLE-VALUE-SETQ args 2 2) (dolist (var (reverse (first args))) (cmpck (not (symbolp var)) "The variable ~s is not a symbol." var) (let* ((var-or-form (chk-symbol-macrolet var)) - (type t)) + (type t)) (unless (when (symbolp var-or-form) - (cmpck (constantp var-or-form) - "The constant ~s is being assigned a value." var-or-form) - (when (or (not (policy-type-assertions)) - (trivial-type-p - (setf type (variable-type-in-env var-or-form)))) - (push var-or-form vars) - t)) - (let ((new-var (gensym))) - (push new-var vars) - (push new-var temp-vars) - (push `(setf ,var-or-form (checked-value ,type ,new-var)) late-bindings))))) + (cmpck (constantp var-or-form) + "The constant ~s is being assigned a value." var-or-form) + (when (or (not (policy-type-assertions)) + (trivial-type-p + (setf type (variable-type-in-env var-or-form)))) + (push var-or-form vars) + t)) + (let ((new-var (gensym))) + (push new-var vars) + (push new-var temp-vars) + (push `(setf ,var-or-form (checked-value ,type ,new-var)) late-bindings))))) (let ((value (second args))) (cond (temp-vars - `(let* (,@temp-vars) - (multiple-value-setq ,vars ,value) - ,@late-bindings)) - ((endp vars) - `(values ,value)) - ((= (length vars) 1) - `(setq ,(first vars) ,value)) - (t - (setq value (c1expr value) - vars (mapcar #'c1vref vars)) - (add-to-set-nodes-of-var-list - vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value)))))) + `(let* (,@temp-vars) + (multiple-value-setq ,vars ,value) + ,@late-bindings)) + ((endp vars) + `(values ,value)) + ((= (length vars) 1) + `(setq ,(first vars) ,value)) + (t + (setq value (c1expr value) + vars (mapcar #'c1vref vars)) + (add-to-set-nodes-of-var-list + vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value)))))) (defun bind-or-set (loc v use-bind) (cond ((not use-bind) - (set-var loc v)) - ((or (plusp (var-ref v)) - (member (var-kind v) '(SPECIAL GLOBAL))) - (bind loc v)))) + (set-var loc v)) + ((or (plusp (var-ref v)) + (member (var-kind v) '(SPECIAL GLOBAL))) + (bind loc v)))) (defun values-loc-or-value0 (i) (if (plusp i) (values-loc i) 'VALUE0)) @@ -191,24 +191,24 @@ ;; We know that at least MIN-VALUES variables will get a value (dotimes (i min-values) (when vars - (let ((v (pop vars)) - (loc (values-loc-or-value0 i))) - (bind-or-set loc v use-bind)))) + (let ((v (pop vars)) + (loc (values-loc-or-value0 i))) + (bind-or-set loc v use-bind)))) (when (some #'useful-var-p vars) (let* ((*lcl* *lcl*) - (nr (make-lcl-var :type :int)) - (tmp (make-lcl-var))) - (wt-nl-open-brace) - (wt-nl "const int " nr " = cl_env_copy->nvalues;") - (wt-nl "cl_object " tmp ";") - (loop for v in vars - for i from min-values - for loc = (values-loc-or-value0 i) - do (when (useful-var-p v) - (wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";") - (bind-or-set tmp v use-bind))) - (wt-nl-close-brace))) + (nr (make-lcl-var :type :int)) + (tmp (make-lcl-var))) + (wt-nl-open-brace) + (wt-nl "const int " nr " = cl_env_copy->nvalues;") + (wt-nl "cl_object " tmp ";") + (loop for v in vars + for i from min-values + for loc = (values-loc-or-value0 i) + do (when (useful-var-p v) + (wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";") + (bind-or-set tmp v use-bind))) + (wt-nl-close-brace))) 'VALUE0)) (defun c2multiple-value-setq (c1form vars form) @@ -223,7 +223,7 @@ (when (= (length variables) 1) (return-from c1multiple-value-bind `(let* ((,(first variables) ,init-form)) - ,@args))) + ,@args))) (multiple-value-bind (body ss ts is other-decls) (c1body args nil) (c1declare-specials ss) @@ -241,14 +241,14 @@ (defun c2multiple-value-bind (c1form vars init-form body) (declare (ignore c1form)) (let* ((*unwind-exit* *unwind-exit*) - (*env-lvl* *env-lvl*) - (*env* *env*) - (*lcl* *lcl*) - (labels nil) - (env-grows nil) - (nr (make-lcl-var :type :int)) - (*inline-blocks* 0) - min-values max-values) + (*env-lvl* *env-lvl*) + (*env* *env*) + (*lcl* *lcl*) + (labels nil) + (env-grows nil) + (nr (make-lcl-var :type :int)) + (*inline-blocks* 0) + min-values max-values) ;; 1) Retrieve the number of output values (multiple-value-setq (min-values max-values) (c1form-values-number init-form)) @@ -258,20 +258,20 @@ (dolist (var vars) (declare (type var var)) (let ((kind (local var))) - (if kind - (when (useful-var-p var) - (maybe-open-inline-block) - (bind (next-lcl) var) - (wt-nl (rep-type->c-name kind) " " *volatile* var ";") - (wt-comment (var-name var))) - (unless env-grows (setq env-grows (var-ref-ccb var)))))) + (if kind + (when (useful-var-p var) + (maybe-open-inline-block) + (bind (next-lcl) var) + (wt-nl (rep-type->c-name kind) " " *volatile* var ";") + (wt-comment (var-name var))) + (unless env-grows (setq env-grows (var-ref-ccb var)))))) ;; 3) If there are closure variables, set up an environment. (when (setq env-grows (env-grows env-grows)) (let ((env-lvl *env-lvl*)) - (maybe-open-inline-block) - (wt-nl "volatile cl_object env" (incf *env-lvl*) - " = env" env-lvl ";"))) + (maybe-open-inline-block) + (wt-nl "volatile cl_object env" (incf *env-lvl*) + " = env" env-lvl ";"))) ;; 4) Assign the values to the variables, compiling the form ;; and binding the variables in the process. diff --git a/src/cmp/cmpname.lsp b/src/cmp/cmpname.lsp index b9d06c3a9..f70c00edf 100644 --- a/src/cmp/cmpname.lsp +++ b/src/cmp/cmpname.lsp @@ -25,15 +25,15 @@ ;; Encode a number in an alphanumeric identifier which is a valid C name. (declare (si::c-local)) (cond ((zerop number) "0") - ((minusp number) (encode-number-in-name (- number))) - (t - (do* ((code "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") - (base (length code)) - (output '()) - (digit 0)) - ((zerop number) (coerce (nreverse output) 'base-string)) - (multiple-value-setq (number digit) (floor number base)) - (push (char code digit) output))))) + ((minusp number) (encode-number-in-name (- number))) + (t + (do* ((code "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") + (base (length code)) + (output '()) + (digit 0)) + ((zerop number) (coerce (nreverse output) 'base-string)) + (multiple-value-setq (number digit) (floor number base)) + (push (char code digit) output))))) (defun unique-init-name (file) "Create a unique name for this initialization function. The current algorithm @@ -41,19 +41,19 @@ relies only on the name of the source file and the time at which it is built. Th should be enough to prevent name collisions for object files built in the same machine." (let* ((path (pathname file)) - (path-hash (logxor (ash (sxhash path) 8) - (ash (sxhash (cddr (pathname-directory path))) 16) - (sxhash (pathname-name path)))) - (seconds (get-universal-time)) - (ms (+ (* seconds 1000) - (mod (floor (* 1000 (get-internal-real-time)) - internal-time-units-per-second) - 1000))) - (tag (concatenate 'base-string - "_ecl" - (encode-number-in-name path-hash) - "_" - (encode-number-in-name ms)))) + (path-hash (logxor (ash (sxhash path) 8) + (ash (sxhash (cddr (pathname-directory path))) 16) + (sxhash (pathname-name path)))) + (seconds (get-universal-time)) + (ms (+ (* seconds 1000) + (mod (floor (* 1000 (get-internal-real-time)) + internal-time-units-per-second) + 1000))) + (tag (concatenate 'base-string + "_ecl" + (encode-number-in-name path-hash) + "_" + (encode-number-in-name ms)))) tag)) (defun init-name-tag (init-name) @@ -62,23 +62,23 @@ machine." (defun search-tag (stream tag) (declare (si::c-local)) (do* ((eof nil) - (key (concatenate 'list tag ":")) - (string key)) + (key (concatenate 'list tag ":")) + (string key)) (nil) (let ((c (read-byte stream nil nil))) (cond ((null c) (return nil)) - ((not (= c (char-code (pop string)))) - (setf string key)) - ((null string) - (return t)))))) + ((not (= c (char-code (pop string)))) + (setf string key)) + ((null string) + (return t)))))) (defun read-name (stream) (declare (si::c-local)) (concatenate 'string - (loop with c = t - until (or (null (setf c (read-byte stream nil nil))) - (= c #.(char-code #\@))) - collect (code-char c)))) + (loop with c = t + until (or (null (setf c (read-byte stream nil nil))) + (= c #.(char-code #\@))) + collect (code-char c)))) (defun find-init-name (file &key (tag "@EcLtAg")) "Search for the initialization function in an object file. Since the @@ -89,7 +89,7 @@ the function name it precedes." (with-open-file (stream file :direction :input :element-type '(unsigned-byte 8)) (when (search-tag stream tag) (let ((name (read-name stream))) - name)))) + name)))) (defun remove-prefix (prefix name) (if (equal 0 (search prefix name)) @@ -112,11 +112,11 @@ the function name it precedes." (init-function-name "CODE" :kind :fas :prefix prefix)) ((:static-library :lib) (init-function-name (remove-prefix +static-library-prefix+ filename) - :kind :lib + :kind :lib :prefix prefix)) ((:shared-library :dll) (init-function-name (remove-prefix +shared-library-prefix+ filename) - :kind :dll + :kind :dll :prefix prefix)) ((:program) (concatenate 'string (or prefix "init_") "ECL_PROGRAM")) @@ -128,31 +128,31 @@ the function name it precedes." (defun init-function-name (s &key (kind :object) (prefix nil)) (flet ((translate-char (c) - (cond ((and (char>= c #\a) (char<= c #\z)) - (char-upcase c)) - ((and (char>= c #\A) (char<= c #\Z)) - c) - ((or (eq c #\-) (eq c #\_)) - #\_) - ((eq c #\*) - #\x) - ((eq c #\?) - #\a) - ((digit-char-p c) - c) - (t - #\p))) - (disambiguation (c) - (case kind - (:object "") + (cond ((and (char>= c #\a) (char<= c #\z)) + (char-upcase c)) + ((and (char>= c #\A) (char<= c #\Z)) + c) + ((or (eq c #\-) (eq c #\_)) + #\_) + ((eq c #\*) + #\x) + ((eq c #\?) + #\a) + ((digit-char-p c) + c) + (t + #\p))) + (disambiguation (c) + (case kind + (:object "") (:program "exe_") - ((:fasl :fas) "fas_") - ((:library :static-library :lib) "lib_") + ((:fasl :fas) "fas_") + ((:library :static-library :lib) "lib_") ((:shared-library :dll) "dll_") - (otherwise (error "Not a valid argument to INIT-FUNCTION-NAME: kind = ~S" - kind))))) + (otherwise (error "Not a valid argument to INIT-FUNCTION-NAME: kind = ~S" + kind))))) (setq s (map 'string #'translate-char (string s))) (concatenate 'string - (or prefix "init_") - (disambiguation kind) - (map 'string #'translate-char (string s))))) + (or prefix "init_") + (disambiguation kind) + (map 'string #'translate-char (string s))))) diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp index 328b9cb3c..f759b0ed6 100644 --- a/src/cmp/cmpnum.lsp +++ b/src/cmp/cmpnum.lsp @@ -122,52 +122,52 @@ (defun most-generic-number-rep-type (r1 r2) (let* ((r1 (rep-type-record r1)) - (r2 (rep-type-record r2))) + (r2 (rep-type-record r2))) (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2)) - r2 - r1)))) + r2 + r1)))) (defun inline-binop (expected-type arg1 arg2 consing non-consing) (let ((arg1-type (inlined-arg-type arg1)) - (arg2-type (inlined-arg-type arg2))) + (arg2-type (inlined-arg-type arg2))) (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type) - (c-number-type-p arg2-type)) - ;; The input arguments have to be coerced to a C - ;; type that fits the output, to avoid overflow which - ;; would happen if we used say, long c = (int)a * (int)b - ;; as the output would be an integer, not a long. - (let* ((arg1-rep (lisp-type->rep-type arg1-type)) - (arg2-rep (lisp-type->rep-type arg2-type)) - (out-rep (lisp-type->rep-type expected-type)) - (max-rep (most-generic-number-rep-type - (most-generic-number-rep-type - arg1-rep arg2-rep) out-rep)) - (max-name (rep-type->c-name max-rep))) - (produce-inline-loc - (list arg1 arg2) - (list arg1-rep arg2-rep) - (list max-rep) - (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" - (unless (eq arg1-rep max-rep) max-name) - non-consing - (unless (eq arg2-rep max-rep) max-name)) - nil t)) - (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) - consing nil t)))) + (c-number-type-p expected-type) + (c-number-type-p arg1-type) + (c-number-type-p arg2-type)) + ;; The input arguments have to be coerced to a C + ;; type that fits the output, to avoid overflow which + ;; would happen if we used say, long c = (int)a * (int)b + ;; as the output would be an integer, not a long. + (let* ((arg1-rep (lisp-type->rep-type arg1-type)) + (arg2-rep (lisp-type->rep-type arg2-type)) + (out-rep (lisp-type->rep-type expected-type)) + (max-rep (most-generic-number-rep-type + (most-generic-number-rep-type + arg1-rep arg2-rep) out-rep)) + (max-name (rep-type->c-name max-rep))) + (produce-inline-loc + (list arg1 arg2) + (list arg1-rep arg2-rep) + (list max-rep) + (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" + (unless (eq arg1-rep max-rep) max-name) + non-consing + (unless (eq arg2-rep max-rep) max-name)) + nil t)) + (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) + consing nil t)))) (defun inline-arith-unop (expected-type arg1 consing non-consing) (let ((arg1-type (inlined-arg-type arg1))) (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type)) - (produce-inline-loc (list arg1) - (list (lisp-type->rep-type arg1-type)) - (list (lisp-type->rep-type expected-type)) - non-consing nil t) - (produce-inline-loc (list arg1) '(:object :object) '(:object) - consing nil t)))) + (c-number-type-p expected-type) + (c-number-type-p arg1-type)) + (produce-inline-loc (list arg1) + (list (lisp-type->rep-type arg1-type)) + (list (lisp-type->rep-type expected-type)) + non-consing nil t) + (produce-inline-loc (list arg1) '(:object :object) '(:object) + consing nil t)))) (define-c-inliner + (return-type &rest arguments &aux arg1 arg2) (when (null arguments) @@ -178,8 +178,8 @@ (loop for arg2 = (pop arguments) for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg1 (save-inline-loc result)) + (return result)))) (define-c-inliner - (return-type arg1 &rest arguments &aux arg2) (when (null arguments) @@ -187,8 +187,8 @@ (loop for arg2 = (pop arguments) for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg1 (save-inline-loc result)) + (return result)))) (define-c-inliner * (return-type &rest arguments &aux arg1 arg2) (when (null arguments) @@ -199,8 +199,8 @@ (loop for arg2 = (pop arguments) for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg1 (save-inline-loc result)) + (return result)))) (define-c-inliner / (return-type arg1 &rest arguments &aux arg2) (when (null arguments) @@ -209,8 +209,8 @@ (loop for arg2 = (pop arguments) for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg1 (save-inline-loc result)) + (return result)))) ;;; ;;; SPECIAL FUNCTIONS @@ -239,21 +239,21 @@ (def-type-propagator expt (fname base exponent) ;; Rules: - ;; (expt fixnum integer) -> integer + ;; (expt fixnum integer) -> integer ;; (expt number-type integer) -> number-type - ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) + ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) ;; (let ((exponent (ensure-real-type exponent))) (values (list base exponent) - (cond ((eql exponent 'integer) - (if (subtypep base 'fixnum) - 'integer - base)) - ((type>= '(real 0 *) base) - (let* ((exponent (ensure-nonrational-type exponent))) - (maximum-number-type exponent base))) - (t - 'number))))) + (cond ((eql exponent 'integer) + (if (subtypep base 'fixnum) + 'integer + base)) + ((type>= '(real 0 *) base) + (let* ((exponent (ensure-nonrational-type exponent))) + (maximum-number-type exponent base))) + (t + 'number))))) (def-type-propagator abs (fname arg) (multiple-value-bind (output arg) diff --git a/src/cmp/cmpopt-bits.lsp b/src/cmp/cmpopt-bits.lsp index c019cbdf6..851ece62e 100644 --- a/src/cmp/cmpopt-bits.lsp +++ b/src/cmp/cmpopt-bits.lsp @@ -29,9 +29,9 @@ (define-compiler-macro ldb (&whole whole bytespec integer) (if (inline-bytespec bytespec) (with-clean-symbols (%pos %size) - `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) - (%pos ,(third bytespec) unsigned-byte)) - (logand (lognot (ash -1 %size)) (ash ,integer (- %pos))))) + `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) + (%pos ,(third bytespec) unsigned-byte)) + (logand (lognot (ash -1 %size)) (ash ,integer (- %pos))))) whole)) (define-compiler-macro ldb-test (&whole whole bytespec integer) @@ -42,82 +42,82 @@ (define-compiler-macro mask-field (&whole whole bytespec integer) (if (inline-bytespec bytespec) (with-clean-symbols (%pos %size) - `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) - (%pos ,(third bytespec) unsigned-byte)) - (logand (ash (lognot (ash -1 %size)) %pos) - ,integer))) + `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) + (%pos ,(third bytespec) unsigned-byte)) + (logand (ash (lognot (ash -1 %size)) %pos) + ,integer))) whole)) (define-compiler-macro dpb (&whole whole newbyte bytespec integer) (if (inline-bytespec bytespec) (with-clean-symbols (%pos %size %mask) - `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) - (%pos ,(third bytespec) unsigned-byte) - (%mask (ash (lognot (ash -1 %size)) %pos) t)) - (logior (logand (ash ,newbyte %pos) %mask) - (logandc2 ,integer %mask)))) + `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) + (%pos ,(third bytespec) unsigned-byte) + (%mask (ash (lognot (ash -1 %size)) %pos) t)) + (logior (logand (ash ,newbyte %pos) %mask) + (logandc2 ,integer %mask)))) whole)) (define-compiler-macro deposit-field (&whole whole newbyte bytespec integer) (if (inline-bytespec bytespec) (with-clean-symbols (%pos %size %mask) - `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) - (%pos ,(third bytespec) unsigned-byte) - (%mask (ash (lognot (ash -1 %size)) %pos) t)) - (logior (logand ,newbyte %mask) - (logandc2 ,integer %mask) - ))) + `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) + (%pos ,(third bytespec) unsigned-byte) + (%mask (ash (lognot (ash -1 %size)) %pos) t)) + (logior (logand ,newbyte %mask) + (logandc2 ,integer %mask) + ))) whole)) (define-setf-expander ldb (&environment env bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (if (inline-bytespec bytespec) - (let* ((bpos (gensym)) - (bsize (gensym)) - (store (gensym)) - (btemp `(byte ,bpos ,bsize)) - (stemp (first stores))) - (values `(,bpos ,bsize ,@temps) - `(,(second bytespec) ,(third bytespec) ,@vals) - `(,store) - `(let ((,stemp (dpb ,store ,btemp ,access-form))) - ,store-form ,store) - `(ldb ,btemp ,access-form))) - (let* ((btemp (gensym)) - (store (gensym)) - (stemp (first stores))) - (values `(,btemp ,@temps) - `(,bytespec ,@vals) - `(,store) - `(let ((,stemp (dpb ,store ,btemp ,access-form))) - ,store-form ,store) - `(ldb ,btemp ,access-form)))))) + (let* ((bpos (gensym)) + (bsize (gensym)) + (store (gensym)) + (btemp `(byte ,bpos ,bsize)) + (stemp (first stores))) + (values `(,bpos ,bsize ,@temps) + `(,(second bytespec) ,(third bytespec) ,@vals) + `(,store) + `(let ((,stemp (dpb ,store ,btemp ,access-form))) + ,store-form ,store) + `(ldb ,btemp ,access-form))) + (let* ((btemp (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,btemp ,@temps) + `(,bytespec ,@vals) + `(,store) + `(let ((,stemp (dpb ,store ,btemp ,access-form))) + ,store-form ,store) + `(ldb ,btemp ,access-form)))))) (define-setf-expander mask-field (&environment env bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (if (inline-bytespec bytespec) - (let* ((bpos (gensym)) - (bsize (gensym)) - (store (gensym)) - (btemp `(byte ,bpos ,bsize)) - (stemp (first stores))) - (values `(,bpos ,bsize ,@temps) - `(,(second bytespec) ,(third bytespec) ,@vals) - `(,store) - `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) - ,store-form ,store) - `(mask-field ,btemp ,access-form))) - (let* ((btemp (gensym)) - (store (gensym)) - (stemp (first stores))) - (values `(,btemp ,@temps) - `(,bytespec ,@vals) - `(,store) - `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) - ,store-form ,store) - `(mask-field ,btemp ,access-form)))))) + (let* ((bpos (gensym)) + (bsize (gensym)) + (store (gensym)) + (btemp `(byte ,bpos ,bsize)) + (stemp (first stores))) + (values `(,bpos ,bsize ,@temps) + `(,(second bytespec) ,(third bytespec) ,@vals) + `(,store) + `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) + ,store-form ,store) + `(mask-field ,btemp ,access-form))) + (let* ((btemp (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,btemp ,@temps) + `(,bytespec ,@vals) + `(,store) + `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) + ,store-form ,store) + `(mask-field ,btemp ,access-form)))))) ;;; ;;; ASH @@ -128,38 +128,38 @@ (define-compiler-macro ash (&whole whole argument shift) (cond ((and (integerp argument) - (integerp shift)) - (ash argument shift)) - ((and (policy-assume-right-type) - (integerp shift)) - (if (zerop shift) - argument - `(shift ,argument ,shift))) - (t - whole))) + (integerp shift)) + (ash argument shift)) + ((and (policy-assume-right-type) + (integerp shift)) + (if (zerop shift) + argument + `(shift ,argument ,shift))) + (t + whole))) (define-c-inliner shift (return-type argument orig-shift) (let* ((arg-type (inlined-arg-type argument)) (arg-c-type (lisp-type->rep-type arg-type)) - (return-c-type (lisp-type->rep-type return-type)) + (return-c-type (lisp-type->rep-type return-type)) (shift (loc-immediate-value (inlined-arg-loc orig-shift)))) (if (or (not (c-integer-rep-type-p arg-c-type)) (not (c-integer-rep-type-p return-c-type))) (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object) "ecl_ash(#0,#1)" nil t) (let* ((arg-bits (c-integer-rep-type-bits arg-c-type)) - (return-bits (c-integer-rep-type-bits return-c-type)) - (max-type (if (and (plusp shift) - (< arg-bits return-bits)) - return-c-type - arg-c-type))) - (produce-inline-loc (list argument) (list max-type) (list return-type) - (format nil - (if (minusp shift) - "((#0) >> (~D))" - "((#0) << (~D))") - (abs shift)) - nil t))))) + (return-bits (c-integer-rep-type-bits return-c-type)) + (max-type (if (and (plusp shift) + (< arg-bits return-bits)) + return-c-type + arg-c-type))) + (produce-inline-loc (list argument) (list max-type) (list return-type) + (format nil + (if (minusp shift) + "((#0) >> (~D))" + "((#0) << (~D))") + (abs shift)) + nil t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -168,9 +168,9 @@ (def-type-propagator logand (fname &rest args) (values args - (if args - (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) - (when (loop for value in args - always (subtypep value int-type)) - (return int-type))) - 'fixnum))) + (if args + (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) + (when (loop for value in args + always (subtypep value int-type)) + (return int-type))) + 'fixnum))) diff --git a/src/cmp/cmpopt-clos.lsp b/src/cmp/cmpopt-clos.lsp index 83107cce5..b6e49bee7 100644 --- a/src/cmp/cmpopt-clos.lsp +++ b/src/cmp/cmpopt-clos.lsp @@ -15,68 +15,68 @@ (defun clos-compiler-macro-expand (fname args) (when (and (si::valid-function-name-p fname) - (fboundp fname)) + (fboundp fname)) (let ((function (fdefinition fname))) (when (typep function 'generic-function) - (generic-function-macro-expand function (list* fname args)))))) + (generic-function-macro-expand function (list* fname args)))))) (defmethod generic-function-macro-expand ((g standard-generic-function) whole) (let* ((output (optimizable-slot-accessor g whole)) - (success (and output t))) + (success (and output t))) (values output success))) (defun optimizable-slot-reader (method whole) (when (typep method 'clos:standard-reader-method) (let ((class (first (clos:method-specializers method)))) (when (clos::class-sealedp class) - (let* ((slotd (clos:accessor-method-slot-definition method)) - (location (clos:slot-definition-location slotd))) - (let ((object (gentemp))) - (cmpnote "Inlining read access to slot ~a from class ~a" - (clos:slot-definition-name slotd) - (class-name class)) - #+(or) - `(let ((,object ,(second whole))) - (locally (declare (notinline ,(first whole))) - (if (typep ,object ',(class-name class)) - (si::instance-ref ,object ,location) - (,(first whole) ,object)))) - ;(format t "~&;;; Inlining accessor ~a" (first whole)) - `(let ((,object ,(second whole))) - (optional-type-check ,object ',class) - (locally (declare (optimize speed (safety 0))) - (si::instance-ref ,object ,location))))))))) + (let* ((slotd (clos:accessor-method-slot-definition method)) + (location (clos:slot-definition-location slotd))) + (let ((object (gentemp))) + (cmpnote "Inlining read access to slot ~a from class ~a" + (clos:slot-definition-name slotd) + (class-name class)) + #+(or) + `(let ((,object ,(second whole))) + (locally (declare (notinline ,(first whole))) + (if (typep ,object ',(class-name class)) + (si::instance-ref ,object ,location) + (,(first whole) ,object)))) + ;(format t "~&;;; Inlining accessor ~a" (first whole)) + `(let ((,object ,(second whole))) + (optional-type-check ,object ',class) + (locally (declare (optimize speed (safety 0))) + (si::instance-ref ,object ,location))))))))) (defun optimizable-slot-writer (method whole) (when (typep method 'clos:standard-writer-method) (let ((class (second (clos:method-specializers method)))) (when (clos::class-sealedp class) - (let* ((slotd (clos:accessor-method-slot-definition method)) - (location (clos:slot-definition-location slotd))) - (let* ((object (gentemp)) - (value (gentemp))) - (cmpnote "Inlining write access to slot ~a from class ~a" - (clos:slot-definition-name slotd) - (class-name class)) - #+(or) - `(let ((,value ,(second whole)) - (,object ,(third whole))) - (locally (declare (notinline ,(first whole))) - (if (typep ,object ',(class-name class)) - (si::instance-set ,object ,location ,value) - (funcall #',(first whole) ,value ,object)))) - ;(format t "~&;;; Inlining accessor ~a" (first whole)) - `(let ((,value ,(second whole)) - (,object ,(third whole))) - (optional-type-check ,object ',class) - (locally (declare (optimize speed (safety 0))) - (si::instance-set ,object ,location ,value))))))))) + (let* ((slotd (clos:accessor-method-slot-definition method)) + (location (clos:slot-definition-location slotd))) + (let* ((object (gentemp)) + (value (gentemp))) + (cmpnote "Inlining write access to slot ~a from class ~a" + (clos:slot-definition-name slotd) + (class-name class)) + #+(or) + `(let ((,value ,(second whole)) + (,object ,(third whole))) + (locally (declare (notinline ,(first whole))) + (if (typep ,object ',(class-name class)) + (si::instance-set ,object ,location ,value) + (funcall #',(first whole) ,value ,object)))) + ;(format t "~&;;; Inlining accessor ~a" (first whole)) + `(let ((,value ,(second whole)) + (,object ,(third whole))) + (optional-type-check ,object ',class) + (locally (declare (optimize speed (safety 0))) + (si::instance-set ,object ,location ,value))))))))) (defun optimizable-slot-accessor (g whole) (and (policy-inline-slot-access) (let ((methods (clos:generic-function-methods g))) - (and methods - (null (rest methods)) - (let* ((principal (first methods))) - (or (optimizable-slot-reader principal whole) - (optimizable-slot-writer principal whole))))))) + (and methods + (null (rest methods)) + (let* ((principal (first methods))) + (or (optimizable-slot-reader principal whole) + (optimizable-slot-writer principal whole))))))) diff --git a/src/cmp/cmpopt-cons.lsp b/src/cmp/cmpopt-cons.lsp index 11faafde3..acd218e8e 100644 --- a/src/cmp/cmpopt-cons.lsp +++ b/src/cmp/cmpopt-cons.lsp @@ -50,20 +50,20 @@ (define-compiler-macro cons (&whole whole &rest args) (labels ((cons-to-lista (x) - (let ((tem (last x))) - (if (and (consp tem) - (consp (car tem)) - (eq (caar tem) 'CONS) - (eql (length (cdar tem)) 2)) - (cons-to-lista (append (butlast x) (cdar tem))) - x)))) + (let ((tem (last x))) + (if (and (consp tem) + (consp (car tem)) + (eq (caar tem) 'CONS) + (eql (length (cdar tem)) 2)) + (cons-to-lista (append (butlast x) (cdar tem))) + x)))) (let (temp) (if (and (eql (length args) 2) - (not (eq args (setq temp (cons-to-lista args))))) - (if (equal '(nil) (last temp)) - (cons 'LIST (butlast temp)) - (cons 'LIST* temp)) - whole)))) + (not (eq args (setq temp (cons-to-lista args))))) + (if (equal '(nil) (last temp)) + (cons 'LIST (butlast temp)) + (cons 'LIST* temp)) + whole)))) ;;; ;;; RPLACA / RPLACD @@ -114,8 +114,8 @@ (progn . #.(loop for n in '(first second third fourth fifth sixth seventh eighth ninth tenth) - for i from 0 - collect `(define-compiler-macro ,n (x) (list 'nth ,i x)))) + for i from 0 + collect `(define-compiler-macro ,n (x) (list 'nth ,i x)))) (define-compiler-macro rest (x) `(cdr ,x)) @@ -126,18 +126,18 @@ (define-compiler-macro pop (&whole whole place &environment env) (if (policy-inline-accessors) (multiple-value-bind (vars vals stores store-form access-form) - (get-setf-expansion place env) - (let* ((store-var (first stores)) - (saved-place (gensym))) - `(let* ,(mapcar #'list - (append vars (list saved-place)) - (append vals (list access-form))) - (declare (:read-only ,@vars)) ; Beppe - (optional-type-check ,saved-place list) - (when ,saved-place - (let ((,store-var (cons-cdr ,saved-place))) - (declare (:read-only ,store-var)) - ,store-form - (setq ,saved-place (cons-car ,saved-place)))) - ,saved-place))) + (get-setf-expansion place env) + (let* ((store-var (first stores)) + (saved-place (gensym))) + `(let* ,(mapcar #'list + (append vars (list saved-place)) + (append vals (list access-form))) + (declare (:read-only ,@vars)) ; Beppe + (optional-type-check ,saved-place list) + (when ,saved-place + (let ((,store-var (cons-cdr ,saved-place))) + (declare (:read-only ,store-var)) + ,store-form + (setq ,saved-place (cons-car ,saved-place)))) + ,saved-place))) whole)) diff --git a/src/cmp/cmpopt-constant.lsp b/src/cmp/cmpopt-constant.lsp index d8a8d2849..118e970ed 100644 --- a/src/cmp/cmpopt-constant.lsp +++ b/src/cmp/cmpopt-constant.lsp @@ -17,12 +17,12 @@ (defun constant-expression-p (form &optional (env *cmp-env*)) (or (constantp form env) (and (consp form) - (let ((head (car form))) + (let ((head (car form))) (or (member head '(IF OR AND NULL NOT PROGN)) (and (get-sysprop head 'pure) (inline-possible head)))) (loop for c in (rest form) - always (constant-expression-p c env))))) + always (constant-expression-p c env))))) (defun extract-constant-value (form &optional failure (env *cmp-env*)) (if (constant-expression-p form env) @@ -33,6 +33,6 @@ (defun constant-value-p (form &optional (env *cmp-env*)) (if (constant-expression-p form env) (handler-case - (values t (cmp-eval form env)) - (error (c) (values nil form))) + (values t (cmp-eval form env)) + (error (c) (values nil form))) (values nil form))) diff --git a/src/cmp/cmpopt-type.lsp b/src/cmp/cmpopt-type.lsp index 95a69ab3e..bfbb5a59a 100644 --- a/src/cmp/cmpopt-type.lsp +++ b/src/cmp/cmpopt-type.lsp @@ -23,19 +23,19 @@ (declare (:read-only ,%limit)) (ext:compiler-typecase ,%limit (fixnum - ;; %LIMIT will be type checked by the compiler to be - ;; a fixnum. We may thus just increase the counter. - (let ((,variable 0)) - (declare (fixnum ,variable) - ,@declarations) - (si::while (< ,variable ,%limit) - ,@body - (reckless (setq ,variable (1+ ,variable)))) - ,@output)) - (t - (let ((,variable 0)) - (declare ,@declarations) + ;; %LIMIT will be type checked by the compiler to be + ;; a fixnum. We may thus just increase the counter. + (let ((,variable 0)) + (declare (fixnum ,variable) + ,@declarations) (si::while (< ,variable ,%limit) ,@body - (setq ,variable (1+ ,variable))) - ,@output)))))))) + (reckless (setq ,variable (1+ ,variable)))) + ,@output)) + (t + (let ((,variable 0)) + (declare ,@declarations) + (si::while (< ,variable ,%limit) + ,@body + (setq ,variable (1+ ,variable))) + ,@output)))))))) diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index 2a9128dc0..4c35a4508 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -25,17 +25,17 @@ (declare (si::c-local)) (let ((forms '())) (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) - interval + interval (unless (eq lower-limit '*) - (push (if (consp lower-limit) - `(> ,var ,(first lower-limit)) - `(>= ,var ,lower-limit)) - forms)) + (push (if (consp lower-limit) + `(> ,var ,(first lower-limit)) + `(>= ,var ,lower-limit)) + forms)) (unless (eq upper-limit '*) - (push (if (consp upper-limit) - `(< ,var ,(first upper-limit)) - `(<= ,var ,upper-limit)) - forms))) + (push (if (consp upper-limit) + `(< ,var ,(first upper-limit)) + `(<= ,var ,upper-limit)) + forms))) forms)) (defun expand-typep (form object type env) @@ -46,110 +46,110 @@ ;; have to output indeed the ORIGINAL FORM, not some intermediate ;; step. Otherwise the compiler macro will enter an infinite loop. (let* ((orig-type type) - aux function - first rest function) + aux function + first rest function) ;; Type must be constant to optimize (if (constantp type env) - (setf type (ext:constant-form-value type env)) - (return-from expand-typep form)) + (setf type (ext:constant-form-value type env)) + (return-from expand-typep form)) (cond ;; Variable declared with a given type - ((and (symbolp object) - (setf aux (cmp-env-search-var object env)) - (subtypep (var-type aux) type)) - t) - ;; Simple ones - ((subtypep 'T type) T) - ((eq type 'NIL) NIL) - ;; - ;; Detect inconsistencies in the provided type. If we run at low - ;; safety, we will simply assume the user knows what she's doing. - ((subtypep type NIL) - (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type) - form) - ;; - ;; There exists a function which checks for this type? - ((setf function (get-sysprop type 'si::type-predicate)) - `(,function ,object)) - ;; - ;; Similar as before, but we assume the user did not give us - ;; the right name, or gave us an equivalent type. - ((loop for (a-type . function-name) in si::+known-typep-predicates+ - when (si::type= type a-type) - do (return `(,function-name ,object)))) - ;; - ;; Complex types defined with DEFTYPE. - ((and (atom type) + ((and (symbolp object) + (setf aux (cmp-env-search-var object env)) + (subtypep (var-type aux) type)) + t) + ;; Simple ones + ((subtypep 'T type) T) + ((eq type 'NIL) NIL) + ;; + ;; Detect inconsistencies in the provided type. If we run at low + ;; safety, we will simply assume the user knows what she's doing. + ((subtypep type NIL) + (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type) + form) + ;; + ;; There exists a function which checks for this type? + ((setf function (get-sysprop type 'si::type-predicate)) + `(,function ,object)) + ;; + ;; Similar as before, but we assume the user did not give us + ;; the right name, or gave us an equivalent type. + ((loop for (a-type . function-name) in si::+known-typep-predicates+ + when (si::type= type a-type) + do (return `(,function-name ,object)))) + ;; + ;; Complex types defined with DEFTYPE. + ((and (atom type) (setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION))) - (expand-typep form object `',(funcall function) env)) - ;; - ;; No optimizations that take up too much space unless requested. - ((not (policy-inline-type-checks)) - form) - ;; - ;; CONS types. They must be checked _before_ sequence types. We - ;; do not produce optimized forms because they can be recursive. - ((and (consp type) (eq first 'CONS)) - form) - ;; - ;; The type denotes a known class and we can check it - #+clos - ((and (symbolp type) (setf aux (find-class type nil))) - `(si::of-class-p ,object ',type)) - ;; - ;; There are no other atomic types to optimize - ((atom type) - form) - ;; - ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't)) - ((progn - (setf rest (rest type) - first (first type)) - (eq first 'NOT)) - `(not (typep ,object ',(first rest)))) - ;; - ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) - ;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...) - ((member first '(OR AND)) - (let ((var (gensym))) - `(let ((,var ,object)) + (expand-typep form object `',(funcall function) env)) + ;; + ;; No optimizations that take up too much space unless requested. + ((not (policy-inline-type-checks)) + form) + ;; + ;; CONS types. They must be checked _before_ sequence types. We + ;; do not produce optimized forms because they can be recursive. + ((and (consp type) (eq first 'CONS)) + form) + ;; + ;; The type denotes a known class and we can check it + #+clos + ((and (symbolp type) (setf aux (find-class type nil))) + `(si::of-class-p ,object ',type)) + ;; + ;; There are no other atomic types to optimize + ((atom type) + form) + ;; + ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't)) + ((progn + (setf rest (rest type) + first (first type)) + (eq first 'NOT)) + `(not (typep ,object ',(first rest)))) + ;; + ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) + ;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...) + ((member first '(OR AND)) + (let ((var (gensym))) + `(let ((,var ,object)) (declare (:read-only ,var)) - (,first ,@(loop for type in rest - collect `(typep ,var ',type)))))) - ;; - ;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...)) - ((eq first 'MEMBER) - `(MEMBER ,object ',rest)) - ;; - ;; (INTEGER * *), etc - ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT - DOUBLE-FLOAT #+long-float LONG-FLOAT)) - (let ((var1 (gensym)) - (var2 (gensym))) - ;; Small optimization: it is easier to check for fixnum - ;; than for integer. Use it when possible. - (when (and (eq first 'integer) - (subtypep type 'fixnum)) - (setf first 'fixnum)) - `(LET ((,var1 ,object) - (,var2 ,(coerce 0 first))) + (,first ,@(loop for type in rest + collect `(typep ,var ',type)))))) + ;; + ;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...)) + ((eq first 'MEMBER) + `(MEMBER ,object ',rest)) + ;; + ;; (INTEGER * *), etc + ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT)) + (let ((var1 (gensym)) + (var2 (gensym))) + ;; Small optimization: it is easier to check for fixnum + ;; than for integer. Use it when possible. + (when (and (eq first 'integer) + (subtypep type 'fixnum)) + (setf first 'fixnum)) + `(LET ((,var1 ,object) + (,var2 ,(coerce 0 first))) (declare (:read-only ,var1) - (type ,first ,var2)) - (AND (TYPEP ,var1 ',first) - (locally (declare (optimize (speed 3) (safety 0) (space 0))) - (setf ,var2 (truly-the ,first ,var1)) - (AND ,@(expand-in-interval-p var2 rest))))))) + (type ,first ,var2)) + (AND (TYPEP ,var1 ',first) + (locally (declare (optimize (speed 3) (safety 0) (space 0))) + (setf ,var2 (truly-the ,first ,var1)) + (AND ,@(expand-in-interval-p var2 rest))))))) ;; ;; (SATISFIES predicate) - ((and (eq first 'SATISFIES) + ((and (eq first 'SATISFIES) (= (list-length type) 2) (symbolp (setf function (second type)))) - `(,function ,object)) - ;; - ;; Complex types with arguments. - ((setf function (get-sysprop first 'SI::DEFTYPE-DEFINITION)) - (expand-typep form object `',(apply function rest) env)) - (t - form)))) + `(,function ,object)) + ;; + ;; Complex types with arguments. + ((setf function (get-sysprop first 'SI::DEFTYPE-DEFINITION)) + (expand-typep form object `',(apply function rest) env)) + (t + form)))) (define-compiler-macro typep (&whole form object type &optional e &environment env) (expand-typep form object type env)) @@ -166,21 +166,21 @@ (multiple-value-bind (declarations body) (si:process-declarations body nil) (let* ((list-var (gensym)) - (typed-var (if (policy-assume-no-errors env) - list-var - `(truly-the cons ,list-var)))) + (typed-var (if (policy-assume-no-errors env) + list-var + `(truly-the cons ,list-var)))) `(block nil - (let* ((,list-var ,expression)) - (si::while ,list-var - (let ((,var (first ,typed-var))) - (declare ,@declarations) - (tagbody - ,@body)) - (setq ,list-var (rest ,typed-var))) - ,(when output-form - `(let ((,var nil)) - (declare ,@declarations) - ,output-form))))))) + (let* ((,list-var ,expression)) + (si::while ,list-var + (let ((,var (first ,typed-var))) + (declare ,@declarations) + (tagbody + ,@body)) + (setq ,list-var (rest ,typed-var))) + ,(when output-form + `(let ((,var nil)) + (declare ,@declarations) + ,output-form))))))) ;;; ;;; COERCE @@ -211,100 +211,100 @@ ;; have to output indeed the ORIGINAL FORM, not some intermediate ;; step. Otherwise the compiler macro will enter an infinite loop. (let* ((orig-type type) - first rest) + first rest) ;; Type must be constant to optimize (if (constantp type env) - (setf type (ext:constant-form-value type env)) - (return-from expand-coerce form)) + (setf type (ext:constant-form-value type env)) + (return-from expand-coerce form)) (cond ;; Trivial case - ((subtypep 't type) - value) - ;; - ;; Detect inconsistencies in the type form. - ((subtypep type 'nil) - (cmperror "Cannot COERCE an expression to an empty type.")) - ;; - ;; No optimizations that take up too much space unless requested. - ((not (policy-inline-type-checks)) - form) - ;; - ;; Search for a simple template above, replacing X by the value. - ((loop for (a-type . template) in +coercion-table+ - when (eq type a-type) - do (return (subst value 'x template)))) - ;; - ;; FIXME! COMPLEX cannot be in +coercion-table+ because - ;; (type= '(complex) '(complex double-float)) == T - ;; - ((eq type 'COMPLEX) - `(let ((y ,value)) - (declare (:read-only y)) - (complex (realpart y) (imagpart y)))) - ;; - ;; Complex types defined with DEFTYPE. - ((and (atom type) - (setq first (get-sysprop type 'SI::DEFTYPE-DEFINITION))) - (expand-coerce form value `',(funcall first) env)) - ;; - ;; CONS types are not coercible. - ((and (consp type) - (eq (first type) 'CONS)) - form) - ;; - ;; Search for a simple template above, but now assuming the user - ;; provided a more complex form of the same value. - ((loop for (a-type . template) in +coercion-table+ - when (si::type= type a-type) - do (return (subst value 'x template)))) - ;; - ;; SEQUENCE types - ((subtypep type 'sequence) - (multiple-value-bind (elt-type length) - (si::closest-sequence-type type) - (if (eq elt-type 'list) - `(si::coerce-to-list ,value) - `(si::coerce-to-vector ,value ',elt-type ',length + ((subtypep 't type) + value) + ;; + ;; Detect inconsistencies in the type form. + ((subtypep type 'nil) + (cmperror "Cannot COERCE an expression to an empty type.")) + ;; + ;; No optimizations that take up too much space unless requested. + ((not (policy-inline-type-checks)) + form) + ;; + ;; Search for a simple template above, replacing X by the value. + ((loop for (a-type . template) in +coercion-table+ + when (eq type a-type) + do (return (subst value 'x template)))) + ;; + ;; FIXME! COMPLEX cannot be in +coercion-table+ because + ;; (type= '(complex) '(complex double-float)) == T + ;; + ((eq type 'COMPLEX) + `(let ((y ,value)) + (declare (:read-only y)) + (complex (realpart y) (imagpart y)))) + ;; + ;; Complex types defined with DEFTYPE. + ((and (atom type) + (setq first (get-sysprop type 'SI::DEFTYPE-DEFINITION))) + (expand-coerce form value `',(funcall first) env)) + ;; + ;; CONS types are not coercible. + ((and (consp type) + (eq (first type) 'CONS)) + form) + ;; + ;; Search for a simple template above, but now assuming the user + ;; provided a more complex form of the same value. + ((loop for (a-type . template) in +coercion-table+ + when (si::type= type a-type) + do (return (subst value 'x template)))) + ;; + ;; SEQUENCE types + ((subtypep type 'sequence) + (multiple-value-bind (elt-type length) + (si::closest-sequence-type type) + (if (eq elt-type 'list) + `(si::coerce-to-list ,value) + `(si::coerce-to-vector ,value ',elt-type ',length ,(and (subtypep type 'simple-array) t))))) - ;; - ;; There are no other atomic types to optimize - ((atom type) - form) - ;; - ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) - ((progn - (setf rest (rest type) first (first type)) - (eq first 'AND)) - `(let ((x ,value)) - ,@(loop for i in rest - collect `(setf x (coerce x ',i))) - x)) - ;; - ;; (COMPLEX whatever) types - ((and (eq first 'complex) - (= (length rest) 1)) - `(let ((y ,value)) - (declare (:read-only y)) - (complex (coerce (realpart y) ',(first rest)) - (coerce (imagpart y) ',(first rest))))) - ;; - ;; (INTEGER * *), etc We have to signal an error if the type - ;; does not match. However, if safety settings are low, we - ;; skip the interval test. - ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT - DOUBLE-FLOAT #+long-float LONG-FLOAT)) - (let ((unchecked (expand-coerce form value `',first env))) - (if (policy-assume-no-errors) - unchecked - `(let ((x ,unchecked)) - (declare (,first x)) - (unless (and ,@(expand-in-interval-p 'x (rest type))) - (si::do-check-type x ',type nil "coerced value")) - x)))) - ;; - ;; We did not find a suitable expansion. - (t - form) - ))) + ;; + ;; There are no other atomic types to optimize + ((atom type) + form) + ;; + ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) + ((progn + (setf rest (rest type) first (first type)) + (eq first 'AND)) + `(let ((x ,value)) + ,@(loop for i in rest + collect `(setf x (coerce x ',i))) + x)) + ;; + ;; (COMPLEX whatever) types + ((and (eq first 'complex) + (= (length rest) 1)) + `(let ((y ,value)) + (declare (:read-only y)) + (complex (coerce (realpart y) ',(first rest)) + (coerce (imagpart y) ',(first rest))))) + ;; + ;; (INTEGER * *), etc We have to signal an error if the type + ;; does not match. However, if safety settings are low, we + ;; skip the interval test. + ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT)) + (let ((unchecked (expand-coerce form value `',first env))) + (if (policy-assume-no-errors) + unchecked + `(let ((x ,unchecked)) + (declare (,first x)) + (unless (and ,@(expand-in-interval-p 'x (rest type))) + (si::do-check-type x ',type nil "coerced value")) + x)))) + ;; + ;; We did not find a suitable expansion. + (t + form) + ))) (define-compiler-macro coerce (&whole form value type &environment env) (expand-coerce form value type env)) @@ -315,20 +315,20 @@ float (policy-inline-type-checks env) (multiple-value-bind (constant-p float) - (constant-value-p float env) + (constant-value-p float env) (when (and constant-p (floatp float)) - (let* ((aux (gentemp)) - (float (type-of float)) - (c-type (lisp-type->rep-type float))) - `(let ((value ,value)) - (declare (:read-only value)) - (compiler-typecase value - (,float value) - (t - (ffi:c-inline (value) (:object) ,c-type - ,(ecase c-type - (:double "ecl_to_double(#0)") - (:float "ecl_to_float(#0)") - (:long-double "ecl_to_long_double(#0)")) - :one-liner t :side-effects nil)))))))) + (let* ((aux (gentemp)) + (float (type-of float)) + (c-type (lisp-type->rep-type float))) + `(let ((value ,value)) + (declare (:read-only value)) + (compiler-typecase value + (,float value) + (t + (ffi:c-inline (value) (:object) ,c-type + ,(ecase c-type + (:double "ecl_to_double(#0)") + (:float "ecl_to_float(#0)") + (:long-double "ecl_to_long_double(#0)")) + :one-liner t :side-effects nil)))))))) form)) diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index 2ecbba13c..793dad731 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -21,8 +21,8 @@ (let ((result (ext:system string))) (unless (zerop result) (cerror "Continues anyway." - "(SYSTEM ~S) returned non-zero value ~D" - string result)) + "(SYSTEM ~S) returned non-zero value ~D" + string result)) result)) (defun save-directory (forms) @@ -44,7 +44,7 @@ (defun old-crappy-system (program args) (let* ((command (format nil "~S~{ ~S~}" program args)) (base-string-command (si:copy-to-simple-base-string command)) - (code (ffi:c-inline (base-string-command) (:object) :int + (code (ffi:c-inline (base-string-command) (:object) :int "system((const char*)(#0->base_string.self))":one-liner t))) (values nil code nil))) @@ -54,9 +54,9 @@ (let* ((*standard-output* ext:+process-standard-output+) (*error-output* ext:+process-error-output+)) (with-current-directory - #-(and cygwin (not ecl-min)) + #-(and cygwin (not ecl-min)) (ext:run-program program args :input nil :output t :error t :wait t) - #+(and cygwin (not ecl-min)) + #+(and cygwin (not ecl-min)) (old-crappy-system program args) )) (cond ((null result) diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index ad5990d49..db224a987 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -18,37 +18,37 @@ (:nicknames "COMPILER") (:use "FFI" "EXT" #+threads "MP" "CL") (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" "*COMPILER-FEATURES*" - "*CC*" - "*CC-OPTIMIZE*" + "*CC*" + "*CC-OPTIMIZE*" "*USER-CC-FLAGS*" "*USER-LD-FLAGS*" "*SUPPRESS-COMPILER-NOTES*" "*SUPPRESS-COMPILER-WARNINGS*" "*SUPPRESS-COMPILER-MESSAGES*" - "BUILD-ECL" - "BUILD-PROGRAM" + "BUILD-ECL" + "BUILD-PROGRAM" "BUILD-FASL" - "BUILD-STATIC-LIBRARY" - "BUILD-SHARED-LIBRARY" - "COMPILER-WARNING" - "COMPILER-NOTE" - "COMPILER-MESSAGE" - "COMPILER-ERROR" - "COMPILER-FATAL-ERROR" - "COMPILER-INTERNAL-ERROR" - "COMPILER-UNDEFINED-VARIABLE" - "COMPILER-MESSAGE-FILE" - "COMPILER-MESSAGE-FILE-POSITION" - "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-MESSAGES*" - "INSTALL-C-COMPILER" + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" + "*SUPPRESS-COMPILER-WARNINGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-MESSAGES*" + "INSTALL-C-COMPILER" "UPDATE-COMPILER-FEATURES") (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" - "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" - "COMPILER-LET")) + "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" + "COMPILER-LET")) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 71affc0e6..d95c383de 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -96,7 +96,7 @@ (<= (list-length decl) 2) (gethash (first decl) *optimization-quality-switches*)) (let* ((old (cmp-env-policy env)) - (flag (if (or (endp (rest decl)) (second decl)) 3 0)) + (flag (if (or (endp (rest decl)) (second decl)) 3 0)) (new (compute-policy (list (list (first decl) flag)) old))) (cmp-env-add-declaration 'optimization (list new) env)))) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index a709a5834..f2a6f8a16 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -29,10 +29,10 @@ (return-from p1propagate (values 'null assumptions))) (when (c1form-p form) (let* ((*cmp-env* (c1form-env form)) - (*compile-file-pathname* (c1form-file form)) - (*compile-file-position* (c1form-file-position form)) - (*current-form* (c1form-form form)) - (*current-toplevel-form* (c1form-toplevel-form form)) + (*compile-file-pathname* (c1form-file form)) + (*compile-file-position* (c1form-file-position form)) + (*current-form* (c1form-form form)) + (*current-toplevel-form* (c1form-toplevel-form form)) (name (c1form-name form)) (propagator (gethash name *p1-dispatch-table*))) (when propagator @@ -44,10 +44,10 @@ (prop-message "~&;;; Propagating ~A gives type ~A" name new-type) (return-from p1propagate - (values (setf (c1form-type form) - (values-type-and (c1form-type form) - new-type)) - assumptions)))))) + (values (setf (c1form-type form) + (values-type-and (c1form-type form) + new-type)) + assumptions)))))) (cmpnote "Refusing to propagate ~A" form) (values (c1form-type form) assumptions)) @@ -57,20 +57,20 @@ (defun p1var (form assumptions var) (let* ((record (and (assoc var assumptions) - (baboon :format-control "Non empty assumptions found in P1VAR"))) - ;; Use the type of C1FORM because it might have been - ;; coerced by a THE form. - (var-type (if record (cdr record) (var-type var))) - (type (type-and var-type (c1form-primary-type form)))) + (baboon :format-control "Non empty assumptions found in P1VAR"))) + ;; Use the type of C1FORM because it might have been + ;; coerced by a THE form. + (var-type (if record (cdr record) (var-type var))) + (type (type-and var-type (c1form-primary-type form)))) (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type) (values type assumptions))) (defun p1values (form assumptions values) (loop for v in values collect (multiple-value-bind (type new-assumptions) - (p1propagate v assumptions) - (setf assumptions new-assumptions) - (values-type-primary-type type)) + (p1propagate v assumptions) + (setf assumptions new-assumptions) + (values-type-primary-type type)) into all-values finally (return (values `(values ,@all-values) assumptions)))) @@ -86,7 +86,7 @@ ROOT. This function takes all those extensions and makes a final list in which type assumptions have been merged, giving the variables the OR type of each of the occurrences in those lists." (unless (and (null root) - (every #'null chains)) + (every #'null chains)) (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions"))) (defun revise-var-type (variable assumptions where-to-stop) @@ -99,14 +99,14 @@ of the occurrences in those lists." (p1propagate body assumptions) (let ((blk-type (blk-type blk))) (values (if blk-type (values-type-or blk-type normal-type) normal-type) - assumptions)))) + assumptions)))) (defun p1return-from (c1form assumptions blk return-type value variable-or-nil) (let* ((values-type (p1propagate value assumptions)) - (blk-type (blk-type blk))) + (blk-type (blk-type blk))) (setf (blk-type blk) (if blk-type - (values-type-or blk-type values-type) - values-type)) + (values-type-or blk-type values-type) + values-type)) (values values-type assumptions))) (defun p1call-global (c1form assumptions fname args) @@ -117,7 +117,7 @@ of the occurrences in those lists." finally (let ((type (propagate-types fname args))) (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" fname (mapcar #'c1form-primary-type args) - type (c1form-type c1form)) + type (c1form-type c1form)) (return (values type assumptions))))) (defun p1call-local (c1form assumptions fun args) @@ -148,7 +148,7 @@ of the occurrences in those lists." (multiple-value-bind (t2 a2) (p1propagate false-branch base-assumptions) (values (values-type-or t1 t2) - (p1merge-branches base-assumptions (list a1 a2))))))) + (p1merge-branches base-assumptions (list a1 a2))))))) (defun p1fmla-not (c1form assumptions form) (multiple-value-bind (type assumptions) @@ -160,13 +160,13 @@ of the occurrences in those lists." with assumptions = orig-assumptions for form in (append butlast (list last)) collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - assumptions) + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + assumptions) into assumptions-list finally (return (values (type-or 'null (values-type-primary-type type)) - (p1merge-branches orig-assumptions - assumptions-list))))) + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1fmla-or (c1form orig-assumptions butlast last) (loop with type @@ -174,15 +174,15 @@ of the occurrences in those lists." with assumptions = orig-assumptions for form in (append butlast (list last)) collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - (setf output-type (type-or (values-type-primary-type type) - output-type)) - assumptions) + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + (setf output-type (type-or (values-type-primary-type type) + output-type)) + assumptions) into assumptions-list finally (return (values output-type - (p1merge-branches orig-assumptions - assumptions-list))))) + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1lambda (c1form assumptions lambda-list doc body &rest not-used) (prop-message "~&;;;~&;;; Propagating function~&;;;") @@ -202,11 +202,11 @@ of the occurrences in those lists." for f in forms unless (or (global-var-p v) (var-set-nodes v)) do (progn - (multiple-value-setq (type assumptions) (p1propagate f assumptions)) - (setf (var-type v) (type-and (values-type-primary-type type) - (var-type v))) - (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v)))) + (multiple-value-setq (type assumptions) (p1propagate f assumptions)) + (setf (var-type v) (type-and (values-type-primary-type type) + (var-type v))) + (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v)))) (multiple-value-bind (type assumptions) (p1propagate body assumptions) (loop for v in vars @@ -224,10 +224,10 @@ of the occurrences in those lists." (loop for v in vars-list for type in (values-type-to-n-types init-form-type (length vars-list)) unless (or (global-var-p v) - (var-set-nodes v)) + (var-set-nodes v)) do (setf (var-type v) (type-and (var-type v) type)) and do (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v))) + (var-name v) (var-type v))) (p1propagate body assumptions))) (defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) @@ -244,16 +244,16 @@ of the occurrences in those lists." for (a-type c1form) in expressions for c1form-type = (p1propagate c1form assumptions) when (or (member a-type '(t otherwise)) - (subtypep var-type a-type)) + (subtypep var-type a-type)) do (setf output-type c1form-type) finally (return (values output-type assumptions))))) (defun p1checked-value (c1form assumptions type value let-form) (let* ((value-type (p1propagate value assumptions)) - (alt-type (p1propagate let-form assumptions))) + (alt-type (p1propagate let-form assumptions))) (if (subtypep value-type type) - value-type - type))) + value-type + type))) (defun p1progv (c1form assumptions variables values body) (let (type) @@ -267,12 +267,12 @@ of the occurrences in those lists." (multiple-value-bind (value-type assumptions) (p1propagate c1form assumptions) (values (type-and (var-type var) (values-type-primary-type value-type)) - assumptions))) + assumptions))) (defun p1psetq (c1form assumptions vars c1forms) (loop for form in c1forms do (multiple-value-bind (new-type assumptions) - (p1propagate form assumptions))) + (p1propagate form assumptions))) (values 'null assumptions)) (defun p1with-stack (c1form assumptions body) @@ -351,21 +351,21 @@ compute it. This version only handles the simplest cases." ((not (member (first array) '(array vector simple-array))) (setf array 'array) - t) + t) ((null (rest array)) t) (t - (let ((x (second array))) - (if (eq x '*) t x)))) + (let ((x (second array))) + (if (eq x '*) t x)))) array)) (def-type-propagator si::aset (fname array-type &rest indices-and-object) (multiple-value-bind (elt-type array-type) (type-from-array-elt array-type) (values (cons array-type - (nconc (make-list (1- (length indices-and-object)) - :initial-element 'si::index) - (list elt-type))) + (nconc (make-list (1- (length indices-and-object)) + :initial-element 'si::index) + (list elt-type))) elt-type))) (def-type-propagator aref (fname array-type &rest indices) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index ad4935714..92d420ef8 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -27,20 +27,20 @@ ;; FIXME: C1CHECKED-VALUE cannot check multiple values. (let ((type (first args))) (if (and (policy-the-is-checked) - (not (and (consp type) - (eq (first type) 'values)))) - (c1checked-value args) - (c1truly-the args)))) + (not (and (consp type) + (eq (first type) 'values)))) + (c1checked-value args) + (c1truly-the args)))) (defun c1truly-the (args) (check-args-number 'TRULY-THE args 2 2) (let* ((form (c1expr (second args))) - (the-type (first args)) - type) + (the-type (first args)) + type) (setf type (values-type-and the-type (c1form-type form))) (if (values-type-primary-type type) (setf (c1form-type form) type) - (cmpwarn "Type mismatch was found in ~s." (cons 'THE args))) + (cmpwarn "Type mismatch was found in ~s." (cons 'THE args))) form)) (defun c1compiler-let (args &aux (symbols nil) (values nil)) @@ -70,24 +70,24 @@ (check-args-number 'FUNCTION args 1 1) (let ((fun (car args))) (cond ((si::valid-function-name-p fun) - (let ((funob (local-function-ref fun t))) - (if funob - (let* ((var (fun-var funob))) - (add-to-read-nodes var (make-c1form* 'VAR :args var))) - (make-c1form* 'FUNCTION + (let ((funob (local-function-ref fun t))) + (if funob + (let* ((var (fun-var funob))) + (add-to-read-nodes var (make-c1form* 'VAR :args var))) + (make-c1form* 'FUNCTION :type 'FUNCTION - :sp-change (not (and (symbolp fun) - (get-sysprop fun 'NO-SP-CHANGE))) - :args 'GLOBAL nil fun)))) + :sp-change (not (and (symbolp fun) + (get-sysprop fun 'NO-SP-CHANGE))) + :args 'GLOBAL nil fun)))) ((and (consp fun) (member (car fun) '(LAMBDA EXT::LAMBDA-BLOCK))) (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) - (let (name body) - (if (eq (first fun) 'EXT::LAMBDA) - (setf name (gensym) body (rest fun)) - (setf name (second fun) body (cddr fun))) - (c1expr `(flet ((,name ,@body)) #',name)))) - (t (cmperr "The function ~s is illegal." fun))))) + (let (name body) + (if (eq (first fun) 'EXT::LAMBDA) + (setf name (gensym) body (rest fun)) + (setf name (second fun) body (cddr fun))) + (c1expr `(flet ((,name ,@body)) #',name)))) + (t (cmperr "The function ~s is illegal." fun))))) (defun c2function (c1form kind funob fun) (declare (ignore c1form)) @@ -112,7 +112,7 @@ ;; new variables created. This way, the same lexical environment ;; can be propagated through nested FLET/LABELS. (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) - (fun-env fun) 0))) + (fun-env fun) 0))) (otherwise (setf (fun-env fun) 0 (fun-level fun) 0))) (let ((previous @@ -122,69 +122,69 @@ (when (similar fun old) (return old))))) (if previous - (progn + (progn (if (eq (fun-closure fun) 'CLOSURE) - (cmpnote "Sharing code for closure") - (cmpnote "Sharing code for local function ~A" (fun-name fun))) - (setf (fun-cfun fun) (fun-cfun previous) - (fun-lambda fun) nil) - previous) - (push fun *local-funs*)))) + (cmpnote "Sharing code for closure") + (cmpnote "Sharing code for local function ~A" (fun-name fun))) + (setf (fun-cfun fun) (fun-cfun previous) + (fun-lambda fun) nil) + previous) + (push fun *local-funs*)))) (defun wt-fdefinition (fun-name) (let* ((name (si::function-block-name fun-name)) - (package (symbol-package name)) - (safe (or (not (safe-compile)) - (and (or (eq package (find-package "CL")) - (eq package (find-package "CLOS")) - (eq package (find-package "SI"))) - (fboundp fun-name) - (functionp (fdefinition fun-name)))))) + (package (symbol-package name)) + (safe (or (not (safe-compile)) + (and (or (eq package (find-package "CL")) + (eq package (find-package "CLOS")) + (eq package (find-package "SI"))) + (fboundp fun-name) + (functionp (fdefinition fun-name)))))) (if (eq name fun-name) - ;; #'symbol - (let ((vv (add-symbol name))) - (if safe - (wt "(" vv "->symbol.gfdef)") - (wt "ecl_fdefinition(" vv ")"))) - ;; #'(SETF symbol) - (if safe - #+(or) - (let ((set-loc (assoc name *setf-definitions*))) - (unless set-loc - (let* ((setf-vv (data-empty-loc)) - (name-vv (add-symbol name)) - (setf-form-vv (add-object fun-name))) - (setf set-loc (list name setf-vv name-vv setf-form-vv)) - (push set-loc *setf-definitions*))) - (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")")) - (let ((set-loc (assoc name *setf-definitions*))) - (unless set-loc - (let* ((setf-vv (data-empty-loc)) - (name-vv (add-symbol name))) - (setf set-loc (list name setf-vv name-vv)) - (push set-loc *setf-definitions*))) - (wt "ECL_CONS_CAR(" (second set-loc) ")")) - (let ((vv (add-symbol fun-name))) - (wt "ecl_fdefinition(" vv ")")))))) + ;; #'symbol + (let ((vv (add-symbol name))) + (if safe + (wt "(" vv "->symbol.gfdef)") + (wt "ecl_fdefinition(" vv ")"))) + ;; #'(SETF symbol) + (if safe + #+(or) + (let ((set-loc (assoc name *setf-definitions*))) + (unless set-loc + (let* ((setf-vv (data-empty-loc)) + (name-vv (add-symbol name)) + (setf-form-vv (add-object fun-name))) + (setf set-loc (list name setf-vv name-vv setf-form-vv)) + (push set-loc *setf-definitions*))) + (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")")) + (let ((set-loc (assoc name *setf-definitions*))) + (unless set-loc + (let* ((setf-vv (data-empty-loc)) + (name-vv (add-symbol name))) + (setf set-loc (list name setf-vv name-vv)) + (push set-loc *setf-definitions*))) + (wt "ECL_CONS_CAR(" (second set-loc) ")")) + (let ((vv (add-symbol fun-name))) + (wt "ecl_fdefinition(" vv ")")))))) (defun environment-accessor (fun) (let* ((env-var (env-var-name *env-lvl*)) - (expected-env-size (fun-env fun))) + (expected-env-size (fun-env fun))) (if (< expected-env-size *env*) - (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) - env-var))) + (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) + env-var))) (defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) (declare (type fun fun)) (let* ((closure (fun-closure fun)) - narg) + narg) (cond ((eq closure 'CLOSURE) - (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," - (environment-accessor fun) - ",Cblock)")) - ((eq closure 'LEXICAL) - (baboon)) - ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args - (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")")) - (t ; empty environment variable number of args - (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock)"))))) + (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," + (environment-accessor fun) + ",Cblock)")) + ((eq closure 'LEXICAL) + (baboon)) + ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args + (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")")) + (t ; empty environment variable number of args + (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock)"))))) diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 8ad6f6ae5..747ba416a 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -13,11 +13,11 @@ ;;;; ;;;; Following special forms are provided: ;;;; -;;;; (WITH-STACK {form}*) -;;;; Executes given forms, restoring the lisp stack on output. -;;;; (STACK-PUSH form) -;;;; (STACK-PUSH-VALUES form) -;;;; (STACK-POP nvalues) +;;;; (WITH-STACK {form}*) +;;;; Executes given forms, restoring the lisp stack on output. +;;;; (STACK-PUSH form) +;;;; (STACK-PUSH-VALUES form) +;;;; (STACK-POP nvalues) ;;;; (in-package "COMPILER") @@ -30,20 +30,20 @@ (defun c1with-stack (forms) (let* ((var (pop forms)) - (body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms)))) + (body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms)))) (make-c1form* 'WITH-STACK - :type (c1form-type body) - :args body))) + :type (c1form-type body) + :args body))) (defun c2with-stack (c1form body) (declare (ignore c1form)) (let* ((new-destination (tmp-destination *destination*)) - (*temp* *temp*)) + (*temp* *temp*)) (wt-nl-open-brace) (wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;") (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);") (let* ((*destination* new-destination) - (*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*))) + (*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*))) (c2expr* body)) (wt-nl "ecl_stack_frame_close(_ecl_inner_frame);") (wt-nl-close-brace) @@ -51,22 +51,22 @@ (defun c1innermost-stack-frame (args) `(c-inline () () :object ,+ecl-stack-frame-variable+ - :one-liner t :side-effects nil)) + :one-liner t :side-effects nil)) (defun c1stack-push (args) `(progn (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" - :one-liner t :side-effects t) + :one-liner t :side-effects t) 1)) (defun c1stack-push-values (args) (let ((frame-var (pop args)) - (form (pop args))) + (form (pop args))) (make-c1form* 'STACK-PUSH-VALUES :type '(VALUES) - :args - (c1expr form) - (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)" - :one-liner t :side-effects t))))) + :args + (c1expr form) + (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)" + :one-liner t :side-effects t))))) (defun c2stack-push-values (c1form form push-statement) (declare (ignore c1form)) @@ -76,10 +76,10 @@ (defun c1stack-pop (args) `(c-inline ,args (t) (values &rest t) - "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" - :one-liner nil :side-effects t)) + "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" + :one-liner nil :side-effects t)) (defun c1apply-from-stack-frame (args) `(c-inline ,args (t t) (values &rest t) - "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" - :one-liner nil :side-effects t)) + "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" + :one-liner nil :side-effects t)) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index 297e0ee2a..ffdd95143 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -34,78 +34,78 @@ (defun maybe-optimize-structure-access (fname args) (let* ((slot-description (get-sysprop fname 'SYS::STRUCTURE-ACCESS))) (when (and slot-description - (inline-possible fname) - (policy-inline-slot-access-p)) + (inline-possible fname) + (policy-inline-slot-access-p)) ;(format t "~%;;; Optimizing structure accessor ~A" fname) (let (structure-type slot-index) - (unless (and (consp slot-description) - (setf structure-type (car slot-description) - slot-index (cdr slot-description)) - (typep slot-index 'fixnum)) - (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A" - fname slot-index) - (return-from maybe-optimize-structure-access nil)) - (unless (= (length args) 1) - (cmpwarn "Too many arguments for structure slot accessor ~A" fname) - (return-from maybe-optimize-structure-access nil)) - (setf args (first args)) - (cond - ((eq structure-type 'list) - `(elt ,args ,slot-index)) - ((eq structure-type 'vector) - `(svref ,args ,slot-index)) - ((consp structure-type) - `(aref (the ,structure-type ,args) ,slot-index)) - (t + (unless (and (consp slot-description) + (setf structure-type (car slot-description) + slot-index (cdr slot-description)) + (typep slot-index 'fixnum)) + (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A" + fname slot-index) + (return-from maybe-optimize-structure-access nil)) + (unless (= (length args) 1) + (cmpwarn "Too many arguments for structure slot accessor ~A" fname) + (return-from maybe-optimize-structure-access nil)) + (setf args (first args)) + (cond + ((eq structure-type 'list) + `(elt ,args ,slot-index)) + ((eq structure-type 'vector) + `(svref ,args ,slot-index)) + ((consp structure-type) + `(aref (the ,structure-type ,args) ,slot-index)) + (t `(,args ',structure-type ,slot-index))))))) (define-compiler-macro si::structure-ref (&whole whole object structure-name index - &environment env) + &environment env) (if (and (policy-inline-slot-access env) - (constantp structure-name env) - (constantp index env)) + (constantp structure-name env) + (constantp index env)) (let* ((index (ext:constant-form-value index env)) - (aux (gensym)) - (form `(ffi:c-inline (,aux ,index) (:object :fixnum) :object - "(#0)->instance.slots[#1]" - :one-liner t))) - (unless (policy-assume-no-errors env) - (setf form - (let ((structure-name (ext:constant-form-value structure-name env))) - `(ext:compiler-typecase ,aux - (,structure-name ,form) - (t (ffi:c-inline (,aux ,structure-name ,index) - (:object :object :fixnum) - :object - "ecl_structure_ref(#0,#1,#2)" - :one-liner t)))))) - `(let ((,aux ,object)) - (declare (:read-only ,aux)) - ,form)) + (aux (gensym)) + (form `(ffi:c-inline (,aux ,index) (:object :fixnum) :object + "(#0)->instance.slots[#1]" + :one-liner t))) + (unless (policy-assume-no-errors env) + (setf form + (let ((structure-name (ext:constant-form-value structure-name env))) + `(ext:compiler-typecase ,aux + (,structure-name ,form) + (t (ffi:c-inline (,aux ,structure-name ,index) + (:object :object :fixnum) + :object + "ecl_structure_ref(#0,#1,#2)" + :one-liner t)))))) + `(let ((,aux ,object)) + (declare (:read-only ,aux)) + ,form)) whole)) (define-compiler-macro si::structure-set (&whole whole object structure-name index value - &environment env) + &environment env) (if (and (policy-inline-slot-access env) - (constantp structure-name env) - (constantp index env)) + (constantp structure-name env) + (constantp index env)) (let* ((index (ext:constant-form-value index env)) - (aux (gensym)) - (form `(ffi:c-inline (,aux ,index ,value) (:object :fixnum :object) :object - "(#0)->instance.slots[#1]=#2" - :one-liner t))) - (unless (policy-assume-no-errors env) - (let ((structure-name (ext:constant-form-value structure-name env))) - (setf form - `(ext:compiler-typecase - ,aux - (,structure-name ,form) - (t (ffi:c-inline (,aux ',structure-name ,index ,value) - (:object :object :fixnum :object) - :object - "ecl_structure_set(#0,#1,#2,#3)" - :one-liner t)))))) - `(let ((,aux ,object)) - (declare (:read-only ,aux)) - ,form)) + (aux (gensym)) + (form `(ffi:c-inline (,aux ,index ,value) (:object :fixnum :object) :object + "(#0)->instance.slots[#1]=#2" + :one-liner t))) + (unless (policy-assume-no-errors env) + (let ((structure-name (ext:constant-form-value structure-name env))) + (setf form + `(ext:compiler-typecase + ,aux + (,structure-name ,form) + (t (ffi:c-inline (,aux ',structure-name ,index ,value) + (:object :object :fixnum :object) + :object + "ecl_structure_set(#0,#1,#2,#3)" + :one-liner t)))))) + `(let ((,aux ,object)) + (declare (:read-only ,aux)) + ,form)) whole)) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index aac75815f..867e8841f 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -15,55 +15,55 @@ (eval-when (:compile-toplevel :execute) (defconstant +all-c1-forms+ - '((LOCATION loc :pure :single-valued) - (VAR var :single-valued) - (SETQ var value-c1form :side-effects) - (PSETQ var-list value-c1form-list :side-effects) - (BLOCK blk-var progn-c1form :pure) - (PROGN body :pure) - (PROGV symbols values form :side-effects) - (TAGBODY tag-var tag-body :pure) - (RETURN-FROM blk-var return-type value variable-or-nil :side-effects) - (FUNCALL fun-value (arg-value*) :side-effects) - (CALL-LOCAL obj-fun (arg-value*) :side-effects) - (CALL-GLOBAL fun-name (arg-value*)) - (CATCH catch-value body :side-effects) - (UNWIND-PROTECT protected-c1form body :side-effects) - (THROW catch-value output-value :side-effects) - (GO tag-var return-type :side-effects) - (C-INLINE (arg-c1form*) - (arg-type-symbol*) - output-rep-type - c-expression-string - side-effects-p - one-liner-p) - (C-PROGN variables forms) - (LOCALS local-fun-list body labels-p :pure) - (IF fmla-c1form true-c1form false-c1form :pure) - (FMLA-NOT fmla-c1form :pure) - (FMLA-AND * :pure) - (FMLA-OR * :pure) - (LAMBDA lambda-list doc body-c1form) - (LET* vars-list var-init-c1form-list decl-body-c1form :pure) - (VALUES values-c1form-list :pure) + '((LOCATION loc :pure :single-valued) + (VAR var :single-valued) + (SETQ var value-c1form :side-effects) + (PSETQ var-list value-c1form-list :side-effects) + (BLOCK blk-var progn-c1form :pure) + (PROGN body :pure) + (PROGV symbols values form :side-effects) + (TAGBODY tag-var tag-body :pure) + (RETURN-FROM blk-var return-type value variable-or-nil :side-effects) + (FUNCALL fun-value (arg-value*) :side-effects) + (CALL-LOCAL obj-fun (arg-value*) :side-effects) + (CALL-GLOBAL fun-name (arg-value*)) + (CATCH catch-value body :side-effects) + (UNWIND-PROTECT protected-c1form body :side-effects) + (THROW catch-value output-value :side-effects) + (GO tag-var return-type :side-effects) + (C-INLINE (arg-c1form*) + (arg-type-symbol*) + output-rep-type + c-expression-string + side-effects-p + one-liner-p) + (C-PROGN variables forms) + (LOCALS local-fun-list body labels-p :pure) + (IF fmla-c1form true-c1form false-c1form :pure) + (FMLA-NOT fmla-c1form :pure) + (FMLA-AND * :pure) + (FMLA-OR * :pure) + (LAMBDA lambda-list doc body-c1form) + (LET* vars-list var-init-c1form-list decl-body-c1form :pure) + (VALUES values-c1form-list :pure) (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) (MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) - (COMPILER-LET symbols values body) - (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) - (RPLACD (dest-c1form value-c1form) :side-effects) + (COMPILER-LET symbols values body) + (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) + (RPLACD (dest-c1form value-c1form) :side-effects) - (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) - (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) + (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) + (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) - (WITH-STACK body :side-effects) + (WITH-STACK body :side-effects) (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) - (ORDINARY c1form :pure) - (LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) - (SI:FSET function-object vv-loc macro-p pprint-p lambda-form - :side-effects) - (MAKE-FORM vv-loc value-c1form :side-effects) - (INIT-FORM vv-loc value-c1form :side-effects) + (ORDINARY c1form :pure) + (LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) + (SI:FSET function-object vv-loc macro-p pprint-p lambda-form + :side-effects) + (MAKE-FORM vv-loc value-c1form :side-effects) + (INIT-FORM vv-loc value-c1form :side-effects) (EXT:COMPILER-TYPECASE var expressions) (CHECKED-VALUE type value-c1form let-form)))) @@ -303,7 +303,7 @@ (defun make-dispatch-table (alist) (loop with hash = (make-hash-table :size (max 128 (* 2 (length alist))) - :test #'eq) + :test #'eq) for (name . function) in alist do (setf (gethash name hash) function) finally (return hash))) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 56bb5c2b3..35b8b294a 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -34,53 +34,53 @@ ;; Find a maximal iteration interval in TAGBODY from first to end ;; then increment the var-ref slot. (labels ((add-reg1 (form) - ;; increase the var-ref in FORM for all vars - (cond ((c1form-p form) - (dolist (v (c1form-args form)) - (add-reg1 v))) - ((consp form) - (dolist (v form) - (add-reg1 v))) - ((var-p form) - (setf (var-ref form) most-positive-fixnum)))) - (jumps-to-p (clause tag-name) - ;; Does CLAUSE have a go TAG-NAME in it? - (cond ((c1form-p clause) - (and (eq (c1form-name clause) 'GO) - (eq (tag-name (c1form-arg 0 clause)) tag-name))) - ((atom clause) nil) - (t (or (jumps-to-p (car clause) tag-name) - (jumps-to-p (cdr clause) tag-name)))))) + ;; increase the var-ref in FORM for all vars + (cond ((c1form-p form) + (dolist (v (c1form-args form)) + (add-reg1 v))) + ((consp form) + (dolist (v form) + (add-reg1 v))) + ((var-p form) + (setf (var-ref form) most-positive-fixnum)))) + (jumps-to-p (clause tag-name) + ;; Does CLAUSE have a go TAG-NAME in it? + (cond ((c1form-p clause) + (and (eq (c1form-name clause) 'GO) + (eq (tag-name (c1form-arg 0 clause)) tag-name))) + ((atom clause) nil) + (t (or (jumps-to-p (car clause) tag-name) + (jumps-to-p (cdr clause) tag-name)))))) (do ((v tagbody (cdr v)) - (end nil) - (first nil)) - ((null v) - (do ((ww first (cdr ww))) - ((eq ww end) (add-reg1 (car ww))) - (add-reg1 (car ww)))) + (end nil) + (first nil)) + ((null v) + (do ((ww first (cdr ww))) + ((eq ww end) (add-reg1 (car ww))) + (add-reg1 (car ww)))) (when (tag-p (car v)) - (unless first (setq first v)) - (do ((w (cdr v) (cdr w)) - (name (tag-name (car v)))) - ((null w)) - (when (jumps-to-p (car w) name) - (setq end w))))))) + (unless first (setq first v)) + (do ((w (cdr v) (cdr w)) + (name (tag-name (car v)))) + ((null w)) + (when (jumps-to-p (car w) name) + (setq end w))))))) ;; FIXME! The variable name should not be a usable one! (defun c1tagbody (orig-body &aux (*cmp-env* (cmp-env-copy)) - (tag-var (make-var :name 'TAGBODY :kind NIL)) - (tag-index 0) - (body nil)) + (tag-var (make-var :name 'TAGBODY :kind NIL)) + (tag-index 0) + (body nil)) ;;; Establish tags. (setq body - (loop for x in orig-body - collect (if (consp x) - x - (let ((tag (make-tag :name x :var tag-var :index tag-index))) - (cmp-env-register-tag (tag-name tag) tag) - (incf tag-index) - tag)))) + (loop for x in orig-body + collect (if (consp x) + x + (let ((tag (make-tag :name x :var tag-var :index tag-index))) + (cmp-env-register-tag (tag-name tag) tag) + (incf tag-index) + tag)))) ;; Split forms according to the tag they are preceded by and compile ;; them grouped by PROGN. This help us use the optimizations in ;; C1PROGN to recognize transfers of control. @@ -89,16 +89,16 @@ with tag-body = nil with this-tag = (make-var :name 'tagbody-beginnnig :kind nil) do (cond ((tag-p form) - (when tag-body - (setf output (cons (c1progn (nreconc tag-body '(nil))) output) - tag-body nil)) - (push form output)) - (t - (push form tag-body))) + (when tag-body + (setf output (cons (c1progn (nreconc tag-body '(nil))) output) + tag-body nil)) + (push form output)) + (t + (push form tag-body))) finally (setf body - (if tag-body - (cons (c1progn (nreconc tag-body '(nil))) output) - output))) + (if tag-body + (cons (c1progn (nreconc tag-body '(nil))) output) + output))) ;;; Reverse the body list, deleting unused tags. (loop for form in body @@ -116,53 +116,53 @@ ;;; Only produce a tagbody if it was needed. (when (zerop (var-ref tag-var)) (return-from c1tagbody (make-c1form* 'PROGN :args - (delete-if #'tag-p body)))) + (delete-if #'tag-p body)))) (when (var-ref-ccb tag-var) (incf *setjmps*)) (add-loop-registers body) (make-c1form* 'TAGBODY :local-vars (list tag-var) - :args tag-var body)) + :args tag-var body)) (defun c2tagbody (c1form tag-loc body) (declare (type var tag-loc) - (ignore c1form)) + (ignore c1form)) (if (null (var-kind tag-loc)) ;; only local goto's (dolist (x body (c2tagbody-body body)) - ;; Allocate labels. - (when (and (tag-p x) (plusp (tag-ref x))) - (setf (tag-label x) (next-label*)) - (setf (tag-unwind-exit x) *unwind-exit*))) + ;; Allocate labels. + (when (and (tag-p x) (plusp (tag-ref x))) + (setf (tag-label x) (next-label*)) + (setf (tag-unwind-exit x) *unwind-exit*))) ;; some tag used non locally or inside an unwind-protect (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) - (*env* *env*) (*env-lvl* *env-lvl*) - (*lex* *lex*) (*lcl* *lcl*) - (*inline-blocks* 0) - (env-grows (env-grows (var-ref-ccb tag-loc)))) - (when env-grows - (let ((env-lvl *env-lvl*)) - (maybe-open-inline-block) - (wt-nl "volatile cl_object env" (incf *env-lvl*) - " = env" env-lvl ";"))) - (when (eq :OBJECT (var-kind tag-loc)) - (setf (var-loc tag-loc) (next-lcl)) - (maybe-open-inline-block) - (wt-nl "cl_object " tag-loc ";") - (setq env-grows t)) ; just to ensure closing the block - (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc) - (wt-nl "if (ecl_frs_push(cl_env_copy," tag-loc ")) {") - ;; Allocate labels. - (dolist (tag body) - (when (and (tag-p tag) (plusp (tag-ref tag))) - (setf (tag-label tag) (next-label)) - (setf (tag-unwind-exit tag) *unwind-exit*) - (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") - (wt-go (tag-label tag)))) - (when (var-ref-ccb tag-loc) - (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")) - (wt-nl "}") - (c2tagbody-body body) - (close-inline-blocks)))) + (*env* *env*) (*env-lvl* *env-lvl*) + (*lex* *lex*) (*lcl* *lcl*) + (*inline-blocks* 0) + (env-grows (env-grows (var-ref-ccb tag-loc)))) + (when env-grows + (let ((env-lvl *env-lvl*)) + (maybe-open-inline-block) + (wt-nl "volatile cl_object env" (incf *env-lvl*) + " = env" env-lvl ";"))) + (when (eq :OBJECT (var-kind tag-loc)) + (setf (var-loc tag-loc) (next-lcl)) + (maybe-open-inline-block) + (wt-nl "cl_object " tag-loc ";") + (setq env-grows t)) ; just to ensure closing the block + (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc) + (wt-nl "if (ecl_frs_push(cl_env_copy," tag-loc ")) {") + ;; Allocate labels. + (dolist (tag body) + (when (and (tag-p tag) (plusp (tag-ref tag))) + (setf (tag-label tag) (next-label)) + (setf (tag-unwind-exit tag) *unwind-exit*) + (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") + (wt-go (tag-label tag)))) + (when (var-ref-ccb tag-loc) + (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")) + (wt-nl "}") + (c2tagbody-body body) + (close-inline-blocks)))) (defun c2tagbody-body (body) ;;; INV: BODY is a list of tags and forms. We have processed the body @@ -171,20 +171,20 @@ ((null l)) (let* ((this-form (first l))) (cond ((tag-p this-form) - (wt-label (tag-label this-form))) - ((endp (rest l)) - ;; Last form, it is never a label! - (c2expr this-form)) - (t - (let* ((next-form (second l)) - (*exit* (if (tag-p next-form) - (tag-label next-form) - (next-label))) - (*unwind-exit* (cons *exit* *unwind-exit*)) - (*destination* 'TRASH)) - (c2expr this-form) - (unless (tag-p next-form) - (wt-label *exit*)))))))) + (wt-label (tag-label this-form))) + ((endp (rest l)) + ;; Last form, it is never a label! + (c2expr this-form)) + (t + (let* ((next-form (second l)) + (*exit* (if (tag-p next-form) + (tag-label next-form) + (next-label))) + (*unwind-exit* (cons *exit* *unwind-exit*)) + (*destination* 'TRASH)) + (c2expr this-form) + (unless (tag-p next-form) + (wt-label *exit*)))))))) (defun c1go (args) (check-args-number 'GO args 1 1) @@ -192,27 +192,27 @@ (unless (or (symbolp name) (integerp name)) (cmperr "The tag name ~s is not a symbol nor an integer." name)) (multiple-value-bind (tag ccb clb unw) - (cmp-env-search-tag name) + (cmp-env-search-tag name) (unless tag - (cmperr "Undefined tag ~A" name)) + (cmperr "Undefined tag ~A" name)) (let ((var (tag-var tag))) - (cond (ccb (setf (tag-ref-ccb tag) t - (var-ref-ccb var) T - (var-kind var) 'CLOSURE)) - (clb (setf (tag-ref-clb tag) t - (var-ref-clb var) t - (var-kind var) 'LEXICAL)) - (unw (unless (var-kind var) - (setf (var-kind var) :OBJECT)))) - (incf (tag-ref tag)) - (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))) + (cond (ccb (setf (tag-ref-ccb tag) t + (var-ref-ccb var) T + (var-kind var) 'CLOSURE)) + (clb (setf (tag-ref-clb tag) t + (var-ref-clb var) t + (var-kind var) 'LEXICAL)) + (unw (unless (var-kind var) + (setf (var-kind var) :OBJECT)))) + (incf (tag-ref tag)) + (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))) (defun c2go (c1form tag nonlocal) (declare (ignore c1form)) (if nonlocal (let ((var (tag-var tag))) - (wt-nl "cl_go(" var ",ecl_make_fixnum(" (tag-index tag) "));")) + (wt-nl "cl_go(" var ",ecl_make_fixnum(" (tag-index tag) "));")) ;; local go (progn - (unwind-no-exit-until (tag-unwind-exit tag)) - (wt-nl) (wt-go (tag-label tag))))) + (unwind-no-exit-until (tag-unwind-exit tag)) + (wt-nl) (wt-go (tag-label tag))))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 010830fd3..9a0a35607 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -32,37 +32,37 @@ (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (when (member fun *toplevel-forms-to-print*) - (print-current-form)) + (print-current-form)) (cond - ((consp fun) (t1ordinary form)) - ((not (symbolp fun)) - (cmperr "~s is illegal function." fun)) - ((eq fun 'QUOTE) - (t1ordinary 'NIL)) - ((setq fd (gethash fun *t1-dispatch-table*)) - (funcall fd args)) - ((gethash fun *c1-dispatch-table*) - (t1ordinary form)) - ((and (setq fd (compiler-macro-function fun)) - (inline-possible fun) - (let ((success nil)) - (multiple-value-setq (fd success) - (cmp-expand-macro fd form)) - success)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* fd)) - ((setq fd (cmp-macro-function fun)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* (cmp-expand-macro fd form))) - (t (t1ordinary form)) - )))) + ((consp fun) (t1ordinary form)) + ((not (symbolp fun)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary 'NIL)) + ((setq fd (gethash fun *t1-dispatch-table*)) + (funcall fd args)) + ((gethash fun *c1-dispatch-table*) + (t1ordinary form)) + ((and (setq fd (compiler-macro-function fun)) + (inline-possible fun) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd form)) + success)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* fd)) + ((setq fd (cmp-macro-function fun)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* (cmp-expand-macro fd form))) + (t (t1ordinary form)) + )))) (defun t1/c1expr (form) (cond ((not *compile-toplevel*) - (c1expr form)) - ((atom form) - (t1ordinary form)) - (t + (c1expr form)) + ((atom form) + (t1ordinary form)) + (t (t1expr* form)))) (defun t2expr (form) @@ -97,15 +97,15 @@ ((eq *emitted-local-funs* *local-funs*)) ;; scan *local-funs* backwards (do ((lfs *local-funs* (cdr lfs))) - ((eq (cdr lfs) *emitted-local-funs*) - (setq *emitted-local-funs* lfs) - (locally (declare (notinline t3local-fun)) - ;; so disassemble can redefine it - (t3local-fun (first lfs))))))) + ((eq (cdr lfs) *emitted-local-funs*) + (setq *emitted-local-funs* lfs) + (locally (declare (notinline t3local-fun)) + ;; so disassemble can redefine it + (t3local-fun (first lfs))))))) (defun ctop-write (name h-pathname data-pathname - &aux def top-output-string - (*volatile* "volatile ")) + &aux def top-output-string + (*volatile* "volatile ")) (setq *top-level-forms* (nreverse *top-level-forms*)) (wt-nl "#include \"" (brief-namestring h-pathname) "\"") @@ -124,10 +124,10 @@ ;;; Initialization function. (let* ((*opened-c-braces* 0) (*aux-closure* nil) - (c-output-file *compiler-output1*) - (*compiler-output1* (make-string-output-stream)) - (*emitted-local-funs* nil) - (*compiler-declared-globals* (make-hash-table))) + (c-output-file *compiler-output1*) + (*compiler-output1* (make-string-output-stream)) + (*emitted-local-funs* nil) + (*compiler-declared-globals* (make-hash-table))) (wt-nl "#include \"" (brief-namestring data-pathname) "\"") (wt-nl "#ifdef __cplusplus") (wt-nl "extern \"C\"") @@ -170,8 +170,8 @@ (when *do-type-propagation* (setq *compiler-phase* 'p1propagate) (dolist (form *top-level-forms*) - (when form - (p1propagate form nil))) + (when form + (p1propagate form nil))) (dolist (fun *local-funs*) (p1propagate (fun-lambda fun) nil))) @@ -186,19 +186,19 @@ (wt-nl-h "static cl_object Cblock;") (let ((num-objects (data-size))) (if (zerop num-objects) - (progn - (wt-nl-h "#undef ECL_DYNAMIC_VV") - (wt-nl-h "#define compiler_data_text 0") - (wt-nl-h "#define VM 0") - (wt-nl-h "#define VMtemp 0") - (wt-nl-h "#define VV NULL")) - (progn - (wt-nl-h "#define VM " (data-permanent-storage-size)) - (wt-nl-h "#define VMtemp " (data-temporary-storage-size))))) + (progn + (wt-nl-h "#undef ECL_DYNAMIC_VV") + (wt-nl-h "#define compiler_data_text 0") + (wt-nl-h "#define VM 0") + (wt-nl-h "#define VMtemp 0") + (wt-nl-h "#define VV NULL")) + (progn + (wt-nl-h "#define VM " (data-permanent-storage-size)) + (wt-nl-h "#define VMtemp " (data-temporary-storage-size))))) (dolist (l *linking-calls*) (let* ((c-name (fourth l)) - (var-name (fifth l))) + (var-name (fifth l))) (wt-nl-h "static cl_object " c-name "(cl_narg, ...);") (wt-nl-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";"))) @@ -209,10 +209,10 @@ ;;; Initial functions for linking calls. (dolist (l *linking-calls*) (let* ((var-name (fifth l)) - (c-name (fourth l)) - (lisp-name (third l))) + (c-name (fourth l)) + (lisp-name (third l))) (wt-nl "static cl_object " c-name "(cl_narg narg, ...)" - "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) + "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) #+(or) (wt-nl-h "static cl_object ECL_SETF_DEFINITION(cl_object setf_vv, cl_object setf_form) { @@ -255,61 +255,61 @@ (defun emit-toplevel-form (form c-output-file) (let ((*ihs-used-p* nil) - (*max-lex* 0) - (*max-env* 0) - (*max-temp* 0) - (*lcl* 0) - (*lex* 0) - (*level* 0) - (*env* 0) - (*env-lvl* 0) - (*temp* 0) - (*compile-to-linking-call* nil) - (*compile-file-truename* (and form (c1form-file form))) - (*compile-file-position* (and form (c1form-file-position form)))) + (*max-lex* 0) + (*max-env* 0) + (*max-temp* 0) + (*lcl* 0) + (*lex* 0) + (*level* 0) + (*env* 0) + (*env-lvl* 0) + (*temp* 0) + (*compile-to-linking-call* nil) + (*compile-file-truename* (and form (c1form-file form))) + (*compile-file-position* (and form (c1form-file-position form)))) ;; We save the C body of the statement, indented, just in case ;; we need to add a {} section with the environment variables. (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) - (with-output-to-string (*compiler-output1*) - (t2expr form))))) + (with-output-to-string (*compiler-output1*) + (t2expr form))))) (if (or (plusp *max-lex*) - (plusp *max-temp*) - (plusp *max-env*) - *ihs-used-p*) - (progn - (wt-nl-open-brace) - (wt-function-locals) - (write-sequence body *compiler-output1*) - (wt-nl-close-brace)) - (write-sequence body *compiler-output1*))) + (plusp *max-temp*) + (plusp *max-env*) + *ihs-used-p*) + (progn + (wt-nl-open-brace) + (wt-function-locals) + (write-sequence body *compiler-output1*) + (wt-nl-close-brace)) + (write-sequence body *compiler-output1*))) (let ((*compiler-output1* c-output-file)) (emit-local-funs)))) (defun c1eval-when (args) (check-args-number 'EVAL-WHEN args 1) (let ((load-flag nil) - (compile-flag nil) - (execute-flag nil)) + (compile-flag nil) + (execute-flag nil)) (dolist (situation (car args)) (case situation - ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) - ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) - ((EVAL :EXECUTE) - (if *compile-toplevel* - (setq compile-flag (or *compile-time-too* compile-flag)) - (setq execute-flag t))) - (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." - situation)))) + ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) + ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((EVAL :EXECUTE) + (if *compile-toplevel* + (setq compile-flag (or *compile-time-too* compile-flag)) + (setq execute-flag t))) + (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." + situation)))) (cond ((not *compile-toplevel*) - (c1progn (and execute-flag (rest args)))) - (load-flag - (let ((*compile-time-too* compile-flag)) - (c1progn (rest args)))) - (compile-flag - (cmp-eval (cons 'PROGN (rest args))) - (c1progn 'NIL)) - (t - (c1progn 'NIL))))) + (c1progn (and execute-flag (rest args)))) + (load-flag + (let ((*compile-time-too* compile-flag)) + (c1progn (rest args)))) + (compile-flag + (cmp-eval (cons 'PROGN (rest args))) + (c1progn 'NIL)) + (t + (c1progn 'NIL))))) (defun t2compiler-let (c1form symbols values body) (declare (ignore c1form)) @@ -334,19 +334,19 @@ ;; share code with it. (dolist (old *global-funs*) (when (similar (fun-lambda new) (fun-lambda old)) - (cmpnote "Sharing code among functions ~A and ~A" - (fun-name new) (fun-name old)) - (setf (fun-shares-with new) old - (fun-cfun new) (fun-cfun old) - (fun-minarg new) (fun-minarg old) - (fun-maxarg new) (fun-maxarg old)) - (return)))) + (cmpnote "Sharing code among functions ~A and ~A" + (fun-name new) (fun-name old)) + (setf (fun-shares-with new) old + (fun-cfun new) (fun-cfun old) + (fun-minarg new) (fun-minarg old) + (fun-maxarg new) (fun-maxarg old)) + (return)))) |# (push new *global-funs*)) (defun print-function (x) (format t "~%" - (fun-name x) (fun-closure x) (fun-level x) (fun-env x))) + (fun-name x) (fun-closure x) (fun-level x) (fun-env x))) (defmacro and! (&body body) `(let ((l (list ,@body))) @@ -455,8 +455,8 @@ (wt-nl "static cl_object L" cfun "(cl_narg narg") (wt-nl-h "static cl_object L" cfun "(cl_narg") (do ((vl arg-types (cdr vl)) - (lcl (1+ *lcl*) (1+ lcl))) - ((endp vl) (wt1 ")")) + (lcl (1+ *lcl*) (1+ lcl))) + ((endp vl) (wt1 ")")) (declare (fixnum lcl)) (wt1 ", cl_object ") (wt-lcl lcl) (wt-h ", cl_object")) @@ -470,7 +470,7 @@ (CHARACTER "CODE_CHAR") (DOUBLE-FLOAT "ecl_make_double_float") (SINGLE-FLOAT "ecl_make_single_float") - #+long-float + #+long-float (LONG-FLOAT "ecl_make_long_float") (otherwise "")) "(LI" cfun "(") @@ -483,8 +483,8 @@ (CHARACTER "ecl_char_code") (DOUBLE-FLOAT "df") (SINGLE-FLOAT "sf") - #+long-float - (LONG-FLOAT "ecl_long_float") + #+long-float + (LONG-FLOAT "ecl_long_float") (otherwise "")) "(") (wt-lcl n) (wt ")") (unless (endp (cdr types)) (wt ","))) @@ -502,7 +502,7 @@ (defun t1ordinary (form) (when *compile-time-too* (cmp-eval form)) (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (*compile-time-too* nil)) (add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form))))) (defun p1ordinary (c1form assumptions form) @@ -511,18 +511,18 @@ (defun t2ordinary (c1form form) (declare (ignore c1form)) (let* ((*exit* (next-label)) - (*unwind-exit* (list *exit*)) + (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) (c2expr form) (wt-label *exit*))) (defun add-load-time-values (form) (let ((previous (append (and (consp *load-time-values*) - (nreverse *load-time-values*)) - (nreverse *make-forms*)))) + (nreverse *load-time-values*)) + (nreverse *make-forms*)))) (when previous (setf *load-time-values* nil - *make-forms* nil) + *make-forms* nil) (setf form (make-c1form* 'PROGN :args (nconc previous (list form)))))) form) @@ -539,18 +539,18 @@ (defun c1load-time-value (args) (check-args-number 'LOAD-TIME-VALUE args 1 2) (let ((form (first args)) - loc) + loc) (cond ((not (listp *load-time-values*)) - ;; When using COMPILE, we set *load-time-values* to 'VALUES and - ;; thus signal that we do not want to compile these forms, but - ;; just to retain their value. - (return-from c1load-time-value (c1constant-value (cmp-eval form) :always t))) + ;; When using COMPILE, we set *load-time-values* to 'VALUES and + ;; thus signal that we do not want to compile these forms, but + ;; just to retain their value. + (return-from c1load-time-value (c1constant-value (cmp-eval form) :always t))) ((typep form '(or list symbol)) - (setf loc (data-empty-loc)) - (push (make-c1form* 'LOAD-TIME-VALUE :args loc (c1expr form)) - *load-time-values*)) - (t - (setf loc (add-object (cmp-eval form))))) + (setf loc (data-empty-loc)) + (push (make-c1form* 'LOAD-TIME-VALUE :args loc (c1expr form)) + *load-time-values*)) + (t + (setf loc (add-object (cmp-eval form))))) (make-c1form* 'LOCATION :type t :args loc))) (defun t2load-time-value (c1form vv-loc form) @@ -599,9 +599,9 @@ (:char . "_ecl_base_char_loc") (:float . "_ecl_float_loc") (:double . "_ecl_double_loc") - #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc") - #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc") - #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc") + #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc") + #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc") + #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc") ((special global closure lexical) . NIL))))) (defun build-debug-lexical-env (var-locations &optional first) @@ -653,50 +653,50 @@ (print-emitting fun) (let* ((lambda-expr (fun-lambda fun)) - (*cmp-env* (c1form-env lambda-expr)) - (*lcl* 0) (*temp* 0) (*max-temp* 0) + (*cmp-env* (c1form-env lambda-expr)) + (*lcl* 0) (*temp* 0) (*max-temp* 0) (*last-label* 0) - (*lex* 0) (*max-lex* 0) - (*env* (fun-env fun)) ; continue growing env - (*max-env* *env*) (*env-lvl* 0) + (*lex* 0) (*max-lex* 0) + (*env* (fun-env fun)) ; continue growing env + (*max-env* *env*) (*env-lvl* 0) (*aux-closure* nil) - (*level* (fun-lexical-levels fun)) - (*exit* 'RETURN) - (*unwind-exit* '(RETURN)) - (*destination* 'RETURN) + (*level* (fun-lexical-levels fun)) + (*exit* 'RETURN) + (*unwind-exit* '(RETURN)) + (*destination* 'RETURN) (*ihs-used-p* nil) - (*opened-c-braces* 0) - (*tail-recursion-info* fun) - (*volatile* (c1form-volatile* lambda-expr))) + (*opened-c-braces* 0) + (*tail-recursion-info* fun) + (*volatile* (c1form-volatile* lambda-expr))) ;; Function declaration. Returns NIL if this function needs no body. (when (t3local-fun-declaration fun) (wt-nl-open-brace) (let ((body (t3local-fun-body fun))) - (wt-function-locals (fun-closure fun)) - (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") - (when (eq (fun-closure fun) 'CLOSURE) - (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) - (wt-nl "cl_object " *volatile* "value0;") - (when (policy-check-stack-overflow) - (wt-nl "ecl_cs_check(cl_env_copy,value0);")) - (when (eq (fun-closure fun) 'CLOSURE) - (t3local-fun-closure-scan fun)) - (write-sequence body *compiler-output1*) - (wt-nl-close-many-braces 0))))) + (wt-function-locals (fun-closure fun)) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (when (eq (fun-closure fun) 'CLOSURE) + (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) + (wt-nl "cl_object " *volatile* "value0;") + (when (policy-check-stack-overflow) + (wt-nl "ecl_cs_check(cl_env_copy,value0);")) + (when (eq (fun-closure fun) 'CLOSURE) + (t3local-fun-closure-scan fun)) + (write-sequence body *compiler-output1*) + (wt-nl-close-many-braces 0))))) (defun t3local-fun-body (fun) (let ((string (make-array 2048 :element-type 'base-char - :adjustable t - :fill-pointer 0))) + :adjustable t + :fill-pointer 0))) (with-output-to-string (*compiler-output1* string) (let ((lambda-expr (fun-lambda fun))) - (c2lambda-expr (c1form-arg 0 lambda-expr) - (c1form-arg 2 lambda-expr) - (fun-cfun fun) - (fun-name fun) - (fun-needs-narg fun) - (fun-required-lcls fun) - (fun-closure fun)))) + (c2lambda-expr (c1form-arg 0 lambda-expr) + (c1form-arg 2 lambda-expr) + (fun-cfun fun) + (fun-name fun) + (fun-needs-narg fun) + (fun-required-lcls fun) + (fun-closure fun)))) string)) (defun t3local-fun-declaration (fun) @@ -709,25 +709,25 @@ (wt-comment-nl "... shares definition with ~a" (fun-name (fun-shares-with fun))) (return-from t3local-fun-declaration nil)) (let* ((comma "") - (lambda-expr (fun-lambda fun)) - (volatile (c1form-volatile* lambda-expr)) - (lambda-list (c1form-arg 0 lambda-expr)) - (requireds (mapcar #'(lambda (v) (next-lcl (var-name v))) - (car lambda-list))) - (narg (fun-needs-narg fun))) + (lambda-expr (fun-lambda fun)) + (volatile (c1form-volatile* lambda-expr)) + (lambda-list (c1form-arg 0 lambda-expr)) + (requireds (mapcar #'(lambda (v) (next-lcl (var-name v))) + (car lambda-list))) + (narg (fun-needs-narg fun))) (let ((cmp-env (c1form-env lambda-expr))) (wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D " - (cmp-env-optimization 'speed cmp-env) - (cmp-env-optimization 'debug cmp-env) - (cmp-env-optimization 'space cmp-env) - (cmp-env-optimization 'safety cmp-env))) + (cmp-env-optimization 'speed cmp-env) + (cmp-env-optimization 'debug cmp-env) + (cmp-env-optimization 'space cmp-env) + (cmp-env-optimization 'safety cmp-env))) (let ((cfun (fun-cfun fun))) (cond ((fun-exported fun) - (wt-nl-h "ECL_DLLEXPORT cl_object " cfun "(") - (wt-nl "cl_object " cfun "(")) - (t - (wt-nl-h "static cl_object " cfun "(") - (wt-nl "static cl_object " cfun "(")))) + (wt-nl-h "ECL_DLLEXPORT cl_object " cfun "(") + (wt-nl "cl_object " cfun "(")) + (t + (wt-nl-h "static cl_object " cfun "(") + (wt-nl "static cl_object " cfun "(")))) (when narg (wt-h volatile "cl_narg") (wt volatile "cl_narg narg") @@ -738,8 +738,8 @@ (setf comma ", ")) (loop for lcl in (setf (fun-required-lcls fun) requireds) do (wt-h comma "cl_object " volatile) - (wt comma "cl_object " volatile lcl) - (setf comma ", ")) + (wt comma "cl_object " volatile lcl) + (setf comma ", ")) (when narg (wt-h ", ...") (wt ", ...")) @@ -749,21 +749,21 @@ (defun fun-closure-variables (fun) (sort (remove-if - #'(lambda (x) - (or - ;; non closure variable - (not (ref-ref-ccb x)) - ;; special variable - (eq (var-kind x) 'special) - ;; not actually referenced - (and (not (var-referenced-in-form x (fun-lambda fun))) - (not (var-changed-in-form x (fun-lambda fun)))) - ;; parameter of this closure - ;; (not yet bound, therefore var-loc is OBJECT) - (eq (var-loc x) 'OBJECT))) - (fun-referenced-vars fun)) - #'> - :key #'var-loc)) + #'(lambda (x) + (or + ;; non closure variable + (not (ref-ref-ccb x)) + ;; special variable + (eq (var-kind x) 'special) + ;; not actually referenced + (and (not (var-referenced-in-form x (fun-lambda fun))) + (not (var-changed-in-form x (fun-lambda fun)))) + ;; parameter of this closure + ;; (not yet bound, therefore var-loc is OBJECT) + (eq (var-loc x) 'OBJECT))) + (fun-referenced-vars fun)) + #'> + :key #'var-loc)) (defun fun-lexical-levels (fun) (if (eq (fun-closure fun) 'LEXICAL) @@ -774,16 +774,16 @@ (let ((clv-used (fun-closure-variables fun))) (wt-nl "/* Scanning closure data ... */") (do ((n (1- (fun-env fun)) (1- n)) - (bs clv-used) - (first t)) - ((or (minusp n) (null bs))) + (bs clv-used) + (first t)) + ((or (minusp n) (null bs))) (wt-nl "CLV" n) (if first - (progn (wt " = env0;") (setf first nil)) - (wt " = _ecl_cdr(CLV" (1+ n) ");")) + (progn (wt " = env0;") (setf first nil)) + (wt " = _ecl_cdr(CLV" (1+ n) ");")) (when (= n (var-loc (first bs))) - (wt-comment (var-name (first clv-used))) - (pop clv-used))) + (wt-comment (var-name (first clv-used))) + (pop clv-used))) (wt-nl-open-brace) (wt " /* ... closure scanning finished */"))) @@ -807,54 +807,54 @@ (when *compile-time-too* (cmp-eval form)) (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (*compile-time-too* nil)) (add-load-time-values (c1fset form))))) (defun c1fset (form) (destructuring-bind (fname def &optional (macro nil) (pprint nil)) (rest form) (let* ((*use-c-global* t) - (fun-form (c1expr def))) + (fun-form (c1expr def))) (when (eq (c1form-name fun-form) 'LOCALS) - (let* ((function-list (c1form-arg 0 fun-form)) - (fun-object (pop function-list)) - (form (c1form-arg 1 fun-form)) - (labels (c1form-arg 2 fun-form))) - (when (and - ;; Only 1 function - (null function-list) - ;; Not closed over anything - (every #'global-var-p (fun-referenced-vars fun-object)) - ;; Referencing the function variable - (eq (c1form-name form) 'VAR) - (eq (c1form-arg 0 form) - (fun-var fun-object))) - (when (fun-no-entry fun-object) - (when macro - (cmperr "Declaration C-LOCAL used in macro ~a" + (let* ((function-list (c1form-arg 0 fun-form)) + (fun-object (pop function-list)) + (form (c1form-arg 1 fun-form)) + (labels (c1form-arg 2 fun-form))) + (when (and + ;; Only 1 function + (null function-list) + ;; Not closed over anything + (every #'global-var-p (fun-referenced-vars fun-object)) + ;; Referencing the function variable + (eq (c1form-name form) 'VAR) + (eq (c1form-arg 0 form) + (fun-var fun-object))) + (when (fun-no-entry fun-object) + (when macro + (cmperr "Declaration C-LOCAL used in macro ~a" (fun-name fun-object))) - (return-from c1fset - (make-c1form* 'SI:FSET :args fun-object nil nil nil nil))) - (when (and (typep macro 'boolean) - (typep pprint '(or integer null)) - (consp fname) - (eq (first fname) 'quote)) - (return-from c1fset - (make-c1form* 'SI:FSET :args - fun-object ;; Function object - (let* ((fname (second fname)) - (in-cl-symbols-p (and (symbolp fname) - (si::mangle-name fname)))) - (add-object fname :permanent t - :duplicate in-cl-symbols-p - :used-p t)) - macro - pprint - ;; The c1form, when we do not optimize - (list (c1expr fname) - fun-form - (c1expr macro) - (c1expr pprint))))))))) + (return-from c1fset + (make-c1form* 'SI:FSET :args fun-object nil nil nil nil))) + (when (and (typep macro 'boolean) + (typep pprint '(or integer null)) + (consp fname) + (eq (first fname) 'quote)) + (return-from c1fset + (make-c1form* 'SI:FSET :args + fun-object ;; Function object + (let* ((fname (second fname)) + (in-cl-symbols-p (and (symbolp fname) + (si::mangle-name fname)))) + (add-object fname :permanent t + :duplicate in-cl-symbols-p + :used-p t)) + macro + pprint + ;; The c1form, when we do not optimize + (list (c1expr fname) + fun-form + (c1expr macro) + (c1expr pprint))))))))) (t1ordinary form))) (defun p1fset (c1form assumptions fun fname macro pprint c1forms) @@ -866,22 +866,22 @@ (defun c2fset (c1form fun fname macro pprint c1forms) (when (fun-no-entry fun) (wt-nl "(void)0; /* No entry created for " - (format nil "~A" (fun-name fun)) - " */") + (format nil "~A" (fun-name fun)) + " */") ;; FIXME! Look at C2LOCALS! (new-local fun) (return-from c2fset)) (unless (and (not (fun-closure fun)) - (eq *destination* 'TRASH)) + (eq *destination* 'TRASH)) (return-from c2fset (c2call-global c1form 'SI:FSET c1forms))) (let ((*inline-blocks* 0) - (loc (data-empty-loc))) + (loc (data-empty-loc))) (push (list loc fname fun) *global-cfuns-array*) ;; FIXME! Look at C2LOCALS! (new-local fun) (wt-nl (if macro "ecl_cmp_defmacro(" "ecl_cmp_defun(") - loc ");") + loc ");") (wt-comment (loc-immediate-value fname)) (close-inline-blocks))) @@ -901,9 +901,9 @@ (minarg (fun-minarg fun)) (maxarg (fun-maxarg fun)) (narg (if (and (= minarg maxarg) - (<= maxarg si:c-arguments-limit)) - maxarg - -1))) + (<= maxarg si:c-arguments-limit)) + maxarg + -1))) (format stream "~%{0,0,~D,0,ecl_make_fixnum(~D),ecl_make_fixnum(~D),(cl_objectfn)~A,ECL_NIL,ecl_make_fixnum(~D)}," narg (vv-location loc) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index bceabf2c9..14db72420 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -18,26 +18,26 @@ ;;; ;;; TYPE is a representation type used by ECL. TYPE is one of: ;;; -;;; T(BOOLEAN) +;;; T(BOOLEAN) ;;; -;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT -;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) -;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) -;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) -;;; (ARRAY FIXNUM) -;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) -;;; STANDARD-OBJECT STRUCTURE-OBJECT -;;; SYMBOL -;;; UNKNOWN +;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT +;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) +;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) +;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) +;;; (ARRAY FIXNUM) +;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) +;;; STANDARD-OBJECT STRUCTURE-OBJECT +;;; SYMBOL +;;; UNKNOWN ;;; -;;; NIL +;;; NIL ;;; ;;; ;;; immediate-type: -;;; FIXNUM int -;;; CHARACTER char -;;; SINGLE-FLOAT float -;;; DOUBLE-FLOAT double +;;; FIXNUM int +;;; CHARACTER char +;;; SINGLE-FLOAT float +;;; DOUBLE-FLOAT double (deftype any () 't) @@ -67,7 +67,7 @@ (defun valid-type-specifier (type) (handler-case (if (subtypep type 'T) - (values t type) + (values t type) (values nil nil)) (error (c) (values nil nil)))) @@ -84,36 +84,36 @@ (when (eq t1 '*) (return-from type-and t2)) (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL - NIL) - ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t1) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t2) - (t - `(AND ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) - t2) - ((eq tag2 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) - t1) - ((null tag1) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL + NIL) + ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t1) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t2) + (t + `(AND ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + t2) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + t1) + ((null tag1) ;(setf c::*compiler-break-enable* t) (break) - (cmpnote "Unknown type ~S. Assuming it is T." t1) - t2) - (t + (cmpnote "Unknown type ~S. Assuming it is T." t1) + t2) + (t ;(setf c::*compiler-break-enable* t) (break) - (cmpnote "Unknown type ~S. Assuming it is T." t2) - t1)))) + (cmpnote "Unknown type ~S. Assuming it is T." t2) + t1)))) (defun values-number-from-type (type) (cond ((or (eq type 'T) (eq type '*)) @@ -131,16 +131,16 @@ ;; pragmatic and thus (VALUES) => NULL [CHECKME!] (let (aux) (cond ((or (atom type) - (not (eq (first type) 'VALUES))) - type) - ((null (setf aux (rest type))) - 'NULL) - ((member (setf aux (first aux)) - '(&optional &rest &allow-other-keys)) - (setf aux (do-values-type-to-n-types type 1)) - (if aux (first aux) 'null)) - (t - aux)))) + (not (eq (first type) 'VALUES))) + type) + ((null (setf aux (rest type))) + 'NULL) + ((member (setf aux (first aux)) + '(&optional &rest &allow-other-keys)) + (setf aux (do-values-type-to-n-types type 1)) + (if aux (first aux) 'null)) + (t + aux)))) (defun-equal-cached values-type-to-n-types (type length) (when (plusp length) @@ -151,46 +151,46 @@ (multiple-value-bind (required optional rest) (split-values-type type) (let* ((optional (loop for i in optional - collect (if (eq i t) i `(or null ,i)))) - (output (nconc required optional)) - (l (length output))) + collect (if (eq i t) i `(or null ,i)))) + (output (nconc required optional)) + (l (length output))) (if (< l length) - (nconc output (make-list (- length l) - :initial-element (if rest (first rest) t))) - (subseq output 0 length))))) + (nconc output (make-list (- length l) + :initial-element (if rest (first rest) t))) + (subseq output 0 length))))) (defun split-values-type (type) (if (or (atom type) (not (eq (first type) 'VALUES))) (values (list type) nil nil nil) (loop with required = '() - with optional-flag = nil - with optional = '() - with rest = '() - with a-o-k = nil - with l = (rest type) - while l - do (let ((typespec (pop l))) - (case typespec - (&allow-other-keys - (setf a-o-k t) - (when l - (cmperr "Syntax error in type expression ~S" type))) - (&optional - (if optional-flag - (push typespec optional) - (setf optional-flag t))) - (&rest - (when (or (null l) - (not (member (rest l) '(() (&allow-other-keys)) - :test #'equal))) - (cmperr "Syntax error in type expression ~S" type)) - (setf rest (list (car l)))) - (otherwise - (if optional-flag - (push typespec optional) - (push typespec required))))) - finally - (return (values (nreverse required) (nreverse optional) + with optional-flag = nil + with optional = '() + with rest = '() + with a-o-k = nil + with l = (rest type) + while l + do (let ((typespec (pop l))) + (case typespec + (&allow-other-keys + (setf a-o-k t) + (when l + (cmperr "Syntax error in type expression ~S" type))) + (&optional + (if optional-flag + (push typespec optional) + (setf optional-flag t))) + (&rest + (when (or (null l) + (not (member (rest l) '(() (&allow-other-keys)) + :test #'equal))) + (cmperr "Syntax error in type expression ~S" type)) + (setf rest (list (car l)))) + (otherwise + (if optional-flag + (push typespec optional) + (push typespec required))))) + finally + (return (values (nreverse required) (nreverse optional) rest a-o-k))))) (defun-equal-cached values-type-or (t1 t2) @@ -282,34 +282,34 @@ (when (eq t1 '*) (return-from type-or t2)) (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t2) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t1) - (t - `(OR ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) - T) - ((eq tag2 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) - T) - ((null tag1) - ;(break) - (cmpnote "Unknown type ~S" t1) - T) - (t - ;(break) - (cmpnote "Unknown type ~S" t2) - T)))) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t2) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t1) + (t + `(OR ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + T) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + T) + ((null tag1) + ;(break) + (cmpnote "Unknown type ~S" t1) + T) + (t + ;(break) + (cmpnote "Unknown type ~S" t2) + T)))) (defun type>= (type1 type2) (subtypep type2 type1)) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 3e7863d62..ffdf18f18 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -16,36 +16,36 @@ (defun c1compiler-typecase (args) (let ((form (first args))) (multiple-value-bind (constantp value) - (constant-value-p form *cmp-env*) + (constant-value-p form *cmp-env*) (when constantp - (loop for (type . forms) in (rest args) - when (typep value type) - do (return-from c1compiler-typecase (c1progn forms)) - finally (baboon :format-control "COMPILER-TYPECASE form missing a T statement"))))) + (loop for (type . forms) in (rest args) + when (typep value type) + do (return-from c1compiler-typecase (c1progn forms)) + finally (baboon :format-control "COMPILER-TYPECASE form missing a T statement"))))) (let* ((var-name (pop args)) - (var (c1vref var-name)) - (first-case (car args))) + (var (c1vref var-name)) + (first-case (car args))) ;; If the first type, which is supposedly the most specific ;; already includes the form, we keep it. This optimizes ;; most cases of CHECKED-VALUE. (if (subtypep (var-type var) (car first-case)) - (c1progn (cdr first-case)) - (let* ((types '()) - (expressions (loop for (type . forms) in args - for c1form = (c1progn forms) - for c1form-type = (c1form-primary-type c1form) - do (push c1form-type types) - collect (list type c1form)))) - (make-c1form* 'EXT:COMPILER-TYPECASE - :type (reduce #'type-or types) - :args var expressions))))) + (c1progn (cdr first-case)) + (let* ((types '()) + (expressions (loop for (type . forms) in args + for c1form = (c1progn forms) + for c1form-type = (c1form-primary-type c1form) + do (push c1form-type types) + collect (list type c1form)))) + (make-c1form* 'EXT:COMPILER-TYPECASE + :type (reduce #'type-or types) + :args var expressions))))) (defun c2compiler-typecase (c1form var expressions) (declare (ignore c1form)) (loop with var-type = (var-type var) for (type form) in expressions when (or (member type '(t otherwise)) - (subtypep var-type type)) + (subtypep var-type type)) return (c2expr form))) (defconstant +simple-type-assertions+ @@ -59,85 +59,85 @@ (defun simple-type-assertion (value type env) (let ((simple-form (cdr (assoc type +simple-type-assertions+)))) (if simple-form - `(ffi:c-inline (,value) (:object) :void ,simple-form - :one-liner nil) - `(ffi:c-inline - ((typep ,value ',type) ',type ,value) - (:bool :object :object) :void - "if (ecl_unlikely(!(#0))) + `(ffi:c-inline (,value) (:object) :void ,simple-form + :one-liner nil) + `(ffi:c-inline + ((typep ,value ',type) ',type ,value) + (:bool :object :object) :void + "if (ecl_unlikely(!(#0))) FEwrong_type_argument(#1,#2);" :one-liner nil)))) (defun expand-type-assertion (value type env compulsory) (cond ((or (not (symbolp value)) - (special-variable-p value) - (symbol-macro-p value)) - ;; If multiple references to the value cost time and space, - ;; or may cause side effects, we save it. - (with-clean-symbols (%asserted-value) - `(let* ((%asserted-value ,value)) - (declare (:read-only %asserted-value)) - ,(expand-type-assertion '%asserted-value type env compulsory)))) - (compulsory - ;; The check has to be produced, independent of the declared - ;; value of the variable (for instance, in LAMBDA arguments). - (simple-type-assertion value type env)) - (t - ;; We may rely on the compiler to choose the appropriate - ;; branch once type propagation has happened. - `(ext:compiler-typecase ,value + (special-variable-p value) + (symbol-macro-p value)) + ;; If multiple references to the value cost time and space, + ;; or may cause side effects, we save it. + (with-clean-symbols (%asserted-value) + `(let* ((%asserted-value ,value)) + (declare (:read-only %asserted-value)) + ,(expand-type-assertion '%asserted-value type env compulsory)))) + (compulsory + ;; The check has to be produced, independent of the declared + ;; value of the variable (for instance, in LAMBDA arguments). + (simple-type-assertion value type env)) + (t + ;; We may rely on the compiler to choose the appropriate + ;; branch once type propagation has happened. + `(ext:compiler-typecase ,value (,type) - (t ,(simple-type-assertion value type env)))))) + (t ,(simple-type-assertion value type env)))))) (defun c1checked-value (args) (let* ((type (pop args)) - (value (pop args)) - form form-type and-type) + (value (pop args)) + form form-type and-type) (cond ((or (trivial-type-p args) (not (policy-type-assertions))) - value) - ((and (consp type) - (eq (first type) 'values)) - (c1checked-value (list (values-type-primary-type type) - value))) - ((and (policy-evaluate-forms) (constantp value *cmp-env*)) - (unless (typep (ext:constant-form-value value *cmp-env*) type) - (cmpwarn "Failed type assertion for value ~A and type ~A" - value type)) - value) - ;; Is the form type contained in the test? - ((progn - (setf form (c1expr value) - form-type (c1form-primary-type form) - and-type (type-and form-type type)) - (eq and-type form-type)) - form) - ;; Are the form type and the test disjoint types? - ((null and-type) - (cmpwarn "The expression ~S is not of the expected type ~S" - value type) - form) - ;; Otherwise, emit a full test - (t - (cmpnote "Checking type of ~S to be ~S" value type) - (let ((full-check - (with-clean-symbols (%checked-value) - `(let* ((%checked-value ,value)) - (declare (:read-only %checked-value)) - ,(expand-type-assertion '%checked-value type *cmp-env* nil) - (truly-the ,type %checked-value))))) - (make-c1form* 'CHECKED-VALUE - :type type - :args type form (c1expr full-check))))))) + value) + ((and (consp type) + (eq (first type) 'values)) + (c1checked-value (list (values-type-primary-type type) + value))) + ((and (policy-evaluate-forms) (constantp value *cmp-env*)) + (unless (typep (ext:constant-form-value value *cmp-env*) type) + (cmpwarn "Failed type assertion for value ~A and type ~A" + value type)) + value) + ;; Is the form type contained in the test? + ((progn + (setf form (c1expr value) + form-type (c1form-primary-type form) + and-type (type-and form-type type)) + (eq and-type form-type)) + form) + ;; Are the form type and the test disjoint types? + ((null and-type) + (cmpwarn "The expression ~S is not of the expected type ~S" + value type) + form) + ;; Otherwise, emit a full test + (t + (cmpnote "Checking type of ~S to be ~S" value type) + (let ((full-check + (with-clean-symbols (%checked-value) + `(let* ((%checked-value ,value)) + (declare (:read-only %checked-value)) + ,(expand-type-assertion '%checked-value type *cmp-env* nil) + (truly-the ,type %checked-value))))) + (make-c1form* 'CHECKED-VALUE + :type type + :args type form (c1expr full-check))))))) (defun c2checked-value (c1form type value let-form) (c2expr (if (subtypep (c1form-primary-type value) type) - value - let-form))) + value + let-form))) (defmacro optional-type-assertion (&whole whole value type &environment env) "If safety settings are high enough, generates a type check on an expression, ensuring that it is satisfied." (when (and (policy-type-assertions env) - (not (trivial-type-p type))) + (not (trivial-type-p type))) (cmpnote "Checking type of ~A to be ~A" value type) `(checked-value ,type ,value))) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 7706f14bb..13f553846 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -20,26 +20,26 @@ ;;; type ;;; (defun and-form-type (type form original-form &optional (mode :safe) - (format-string "") &rest format-args) + (format-string "") &rest format-args) (let* ((type2 (c1form-primary-type form)) - (type1 (type-and type type2))) + (type1 (type-and type type2))) ;; We only change the type if it is not NIL. Is this wise? (if type1 - (setf (c1form-type form) type1) - (funcall (if (eq mode :safe) #'cmperr #'cmpwarn) - "~?, the type of the form ~s is ~s, not ~s." format-string - format-args original-form type2 type)) + (setf (c1form-type form) type1) + (funcall (if (eq mode :safe) #'cmperr #'cmpwarn) + "~?, the type of the form ~s is ~s, not ~s." format-string + format-args original-form type2 type)) form)) (defun default-init (var &optional warn) (declare (ignore warn)) (let ((new-value (cdr (assoc (var-type var) - '((fixnum . 0) (character . #\space) + '((fixnum . 0) (character . #\space) #+long-float (long-float 0.0L1) - (double-float . 0.0D1) (single-float . 0.0F1)) - :test #'subtypep)))) + (double-float . 0.0D1) (single-float . 0.0F1)) + :test #'subtypep)))) (if new-value - (c1constant-value new-value :only-small-values t) + (c1constant-value new-value :only-small-values t) (c1nil)))) (defun expand-deftype (type) @@ -64,7 +64,7 @@ (multiple-value-bind (req-types opt-types rest-flag key-flag key-types allow-other-keys) (si::process-lambda-list arg-types 'ftype) - (declare (ignore rest-flag key-flag allow-other-keys)) + (declare (ignore rest-flag key-flag allow-other-keys)) (nconc (loop for var in requireds for type in (rest req-types) @@ -173,14 +173,14 @@ (multiple-value-bind (trivial valid) (subtypep 't type) (cond ((and trivial valid) - value) - ((multiple-value-setq (valid value) (constant-value-p value env)) - (si::maybe-quote value)) - (t - (with-clean-symbols (%value) - `(let* ((%value ,value)) - ,(type-error-check '%value (replace-invalid-types type)) - (truly-the ,type %value))))))) + value) + ((multiple-value-setq (valid value) (constant-value-p value env)) + (si::maybe-quote value)) + (t + (with-clean-symbols (%value) + `(let* ((%value ,value)) + ,(type-error-check '%value (replace-invalid-types type)) + (truly-the ,type %value))))))) (defun replace-invalid-types (type) ;; Some types which are acceptable in DECLARE are not @@ -190,12 +190,12 @@ (if (atom type) type (let ((name (car type))) - (case name - (FUNCTION 'FUNCTION) - ((OR AND NOT CONS) - (list* name (mapcar #'replace-invalid-types (rest type)))) - (otherwise - type))))) + (case name + (FUNCTION 'FUNCTION) + ((OR AND NOT CONS) + (list* name (mapcar #'replace-invalid-types (rest type)))) + (otherwise + type))))) (defmacro optional-type-check (&whole whole value type &environment env) (declare (ignore env)) @@ -205,7 +205,7 @@ (defmacro with-let*-type-check (triplets &body body) `(let* ,(loop for (var value type) in triplets - collect `(,var (assert-type-if-known ,value ,type))) + collect `(,var (assert-type-if-known ,value ,type))) (declare (:read-only ,@(mapcar #'car triplets))) ,@body)) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 9b909b74d..de5b57ded 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -29,53 +29,53 @@ ;;; (defstruct (ref (:print-object print-ref)) - name ;;; Identifier of reference. - (ref 0 :type fixnum) ;;; Number of references. - ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the index into the closure env - ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the lex-address for the - ;;; block id, or NIL. - read-nodes ;;; Nodes (c1forms) in which the reference occurs + name ;;; Identifier of reference. + (ref 0 :type fixnum) ;;; Number of references. + ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the index into the closure env + ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the lex-address for the + ;;; block id, or NIL. + read-nodes ;;; Nodes (c1forms) in which the reference occurs ) (deftype OBJECT () `(not (or fixnum character float))) (defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var)) -; name ;;; Variable name. +; name ;;; Variable name. ; (ref 0 :type fixnum) - ;;; Number of references to the variable (-1 means IGNORE). -; ref-ccb ;;; Cross closure reference: T or NIL. -; ref-clb ;;; Cross local function reference: T or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - set-nodes ;;; Nodes in which the variable is modified - kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, + ;;; Number of references to the variable (-1 means IGNORE). +; ref-ccb ;;; Cross closure reference: T or NIL. +; ref-clb ;;; Cross local function reference: T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + set-nodes ;;; Nodes in which the variable is modified + kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, ;;; or some C representation type (:FIXNUM, :CHAR, etc) (function *current-function*) - ;;; For local variables, in which function it was created. - ;;; For global variables, it doesn't have a meaning. + ;;; For local variables, in which function it was created. + ;;; For global variables, it doesn't have a meaning. (functions-setting nil) (functions-reading nil) - ;;; Functions in which the variable has been modified or read. - (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can - ;;; be allocated on the c-stack: OBJECT means - ;;; the variable is declared as OBJECT, and CLB means - ;;; the variable is referenced across Level Boundary and thus - ;;; cannot be allocated on the C stack. Note that OBJECT is - ;;; set during variable binding and CLB is set when the - ;;; variable is used later, and therefore CLB may supersede - ;;; OBJECT. - ;;; During Pass 2: - ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: - ;;; the cvar for the C variable that holds the value. - ;;; For LEXICAL or CLOSURE: the frame-relative address for - ;;; the variable in the form of a cons '(lex-levl . lex-ndx) - ;;; lex-levl is the level of lexical environment - ;;; lex-ndx is the index within the array for this env. - ;;; For SPECIAL and GLOBAL: the vv-index for variable name. - (type t) ;;; Type of the variable. + ;;; Functions in which the variable has been modified or read. + (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can + ;;; be allocated on the c-stack: OBJECT means + ;;; the variable is declared as OBJECT, and CLB means + ;;; the variable is referenced across Level Boundary and thus + ;;; cannot be allocated on the C stack. Note that OBJECT is + ;;; set during variable binding and CLB is set when the + ;;; variable is used later, and therefore CLB may supersede + ;;; OBJECT. + ;;; During Pass 2: + ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: + ;;; the cvar for the C variable that holds the value. + ;;; For LEXICAL or CLOSURE: the frame-relative address for + ;;; the variable in the form of a cons '(lex-levl . lex-ndx) + ;;; lex-levl is the level of lexical environment + ;;; lex-ndx is the index within the array for this env. + ;;; For SPECIAL and GLOBAL: the vv-index for variable name. + (type t) ;;; Type of the variable. #-new-cmp (index -1) ;;; position in *vars*. Used by similar. #-new-cmp @@ -86,10 +86,10 @@ ;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE ;;; Here are examples of function FOO for the 3 cases: -;;; 1. (flet ((foo () (bar))) (foo)) CFUN -;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN +;;; 1. (flet ((foo () (bar))) (foo)) CFUN +;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN ;;; 3. (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE -;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE +;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE ;;; A function can be referenced across a ccb without being a closure, e.g: ;;; (flet ((foo () (bar))) #'(lambda () (foo))) @@ -116,83 +116,83 @@ ;;; therefore we need field funob. (defstruct (fun (:include ref)) -; name ;;; Function name. -; (ref 0 :type fixnum) ;;; Number of references. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the vs-address for the - ;;; function closure, or NIL. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL, depending on whether a - ;;; function object will be built. - ;;; During Pass2, the vs-address for the function - ;;; closure, or NIL. -; ref-clb ;;; Unused. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - cfun ;;; The cfun for the function. +; name ;;; Function name. +; (ref 0 :type fixnum) ;;; Number of references. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; function closure, or NIL. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL, depending on whether a + ;;; function object will be built. + ;;; During Pass2, the vs-address for the function + ;;; closure, or NIL. +; ref-clb ;;; Unused. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + cfun ;;; The cfun for the function. #+new-cmp - (last-lcl 0) ;;; Number of local variables (just to bookkeep names) + (last-lcl 0) ;;; Number of local variables (just to bookkeep names) #+new-cmp - (last-label 0) ;;; Number of generated labels (same as last-lcl) - (level 0) ;;; Level of lexical nesting for a function. - (env 0) ;;; Size of env of closure. - (global nil) ;;; Global lisp function. - (exported nil) ;;; Its C name can be seen outside the module. - (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no - ;;; function object and the C function is called - ;;; directly - (shares-with nil) ;;; T if this function shares the C code with another one. - ;;; In that case we need not emit this one. - closure ;;; During Pass2, T if env is used inside the function - var ;;; the variable holding the funob - description ;;; Text for the object, in case NAME == NIL. + (last-label 0) ;;; Number of generated labels (same as last-lcl) + (level 0) ;;; Level of lexical nesting for a function. + (env 0) ;;; Size of env of closure. + (global nil) ;;; Global lisp function. + (exported nil) ;;; Its C name can be seen outside the module. + (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no + ;;; function object and the C function is called + ;;; directly + (shares-with nil) ;;; T if this function shares the C code with another one. + ;;; In that case we need not emit this one. + closure ;;; During Pass2, T if env is used inside the function + var ;;; the variable holding the funob + description ;;; Text for the object, in case NAME == NIL. #+new-cmp - lambda-list ;;; List of (requireds optionals rest-var keywords-p - ;;; keywords allow-other-keys-p) - lambda ;;; Lambda c1-form for this function. + lambda-list ;;; List of (requireds optionals rest-var keywords-p + ;;; keywords allow-other-keys-p) + lambda ;;; Lambda c1-form for this function. lambda-expression ;;; LAMBDA or LAMBDA-BLOCK expression - (minarg 0) ;;; Min. number arguments that the function receives. + (minarg 0) ;;; Min. number arguments that the function receives. (maxarg call-arguments-limit) - ;;; Max. number arguments that the function receives. + ;;; Max. number arguments that the function receives. (return-type '(VALUES &REST T)) #+new-cmp - doc ;;; Documentation + doc ;;; Documentation (parent *current-function*) - ;;; Parent function, NIL if global. - (local-vars nil) ;;; List of local variables created here. - (referenced-vars nil) ;;; List of external variables referenced here. - (referenced-funs nil) ;;; List of external functions called in this one. - ;;; We only register direct calls, not calls via object. + ;;; Parent function, NIL if global. + (local-vars nil) ;;; List of local variables created here. + (referenced-vars nil) ;;; List of external variables referenced here. + (referenced-funs nil) ;;; List of external functions called in this one. + ;;; We only register direct calls, not calls via object. (referencing-funs nil);;; Functions that reference this one - (child-funs nil) ;;; List of local functions defined here. + (child-funs nil) ;;; List of local functions defined here. #+new-cmp - (debug 0) ;;; Debug quality + (debug 0) ;;; Debug quality (file (car ext:*source-location*)) - ;;; Source file or NIL + ;;; Source file or NIL (file-position (or (cdr ext:*source-location*) *compile-file-position*)) - ;;; Top-level form number in source file + ;;; Top-level form number in source file #+new-cmp (toplevel-form *current-toplevel-form*) #+new-cmp - code-gen-props ;;; Extra properties for code generation + code-gen-props ;;; Extra properties for code generation (cmp-env (cmp-env-copy)) ;;; Environment required-lcls ;;; Names of the function arguments ) (defstruct (blk (:include ref)) -; name ;;; Block name. -; (ref 0 :type fixnum) ;;; Number of references. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the ccb-lex for the - ;;; block id, or NIL. -; ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the lex-address for the - ;;; block id, or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - exit ;;; Where to return. A label. - destination ;;; Where the value of the block to go. - var ;;; Variable containing the block ID. +; name ;;; Block name. +; (ref 0 :type fixnum) ;;; Number of references. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the ccb-lex for the + ;;; block id, or NIL. +; ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the lex-address for the + ;;; block id, or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + exit ;;; Where to return. A label. + destination ;;; Where the value of the block to go. + var ;;; Variable containing the block ID. #-new-cmp (type '(VALUES &REST T)) ;;; Estimated type. #+new-cmp @@ -200,46 +200,46 @@ ) (defstruct (tag (:include ref)) -; name ;;; Tag name. -; (ref 0 :type fixnum) ;;; Number of references. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. -; ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - label ;;; Where to jump: a label. - unwind-exit ;;; Where to unwind-no-exit. - var ;;; Variable containing frame ID. - index ;;; An integer denoting the label. +; name ;;; Tag name. +; (ref 0 :type fixnum) ;;; Number of references. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. +; ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + label ;;; Where to jump: a label. + unwind-exit ;;; Where to unwind-no-exit. + var ;;; Variable containing frame ID. + index ;;; An integer denoting the label. #+new-cmp env ;;; Tag environment. ) (defstruct (info) - (local-vars nil) ;;; List of var-objects created directly in the form. + (local-vars nil) ;;; List of var-objects created directly in the form. #-new-cmp (type '(VALUES &REST T)) ;;; Type of the form. - (sp-change nil) ;;; Whether execution of the form may change - ;;; the value of a special variable. - (volatile nil) ;;; whether there is a possible setjmp. Beppe + (sp-change nil) ;;; Whether execution of the form may change + ;;; the value of a special variable. + (volatile nil) ;;; whether there is a possible setjmp. Beppe ) (defstruct (inline-info) - name ;;; Function name - arg-rep-types ;;; List of representation types for the arguments - return-rep-type ;;; Representation type for the output - arg-types ;;; List of lisp types for the arguments - return-type ;;; Lisp type for the output - exact-return-type ;;; Only use this expansion when the output is - ;;; declared to have a subtype of RETURN-TYPE + name ;;; Function name + arg-rep-types ;;; List of representation types for the arguments + return-rep-type ;;; Representation type for the output + arg-types ;;; List of lisp types for the arguments + return-type ;;; Lisp type for the output + exact-return-type ;;; Only use this expansion when the output is + ;;; declared to have a subtype of RETURN-TYPE multiple-values ;;; Works with all destinations, including VALUES / RETURN - expansion ;;; C template containing the expansion - one-liner ;;; Whether the expansion spans more than one line + expansion ;;; C template containing the expansion + one-liner ;;; Whether the expansion spans more than one line ) (defstruct (c1form (:include info) - (:print-object print-c1form) - (:constructor do-make-c1form)) + (:print-object print-c1form) + (:constructor do-make-c1form)) (name nil) (parents nil) #+new-cmp diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index e2312e182..92cb6ef27 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -82,9 +82,9 @@ ((prefix :initform "Note" :accessor compiler-message-prefix) (format :initform +note-format+ :accessor compiler-message-format) (file :initarg :file :initform *compile-file-pathname* - :accessor compiler-message-file) + :accessor compiler-message-file) (position :initarg :file :initform *compile-file-position* - :accessor compiler-message-file-position) + :accessor compiler-message-file-position) (toplevel-form :initarg :form :initform *current-toplevel-form* :accessor compiler-message-toplevel-form) (form :initarg :form :initform *current-form* @@ -172,16 +172,16 @@ (defun do-compilation-unit (closure &key override) (cond (override - (let* ((*active-protection* nil)) - (do-compilation-unit closure))) - ((null *active-protection*) - (let* ((*active-protection* t) - (*pending-actions* nil)) - (unwind-protect (do-compilation-unit closure) - (loop for action in *pending-actions* - do (funcall action))))) - (t - (funcall closure)))) + (let* ((*active-protection* nil)) + (do-compilation-unit closure))) + ((null *active-protection*) + (let* ((*active-protection* t) + (*pending-actions* nil)) + (unwind-protect (do-compilation-unit closure) + (loop for action in *pending-actions* + do (funcall action))))) + (t + (funcall closure)))) (defmacro with-compilation-unit ((&rest options) &body body) `(do-compilation-unit #'(lambda () ,@body) ,@options)) @@ -190,9 +190,9 @@ `(let ((*compiler-conditions* nil)) (declare (special *compiler-conditions*)) (restart-case - (handler-bind ((compiler-note #'handle-compiler-note) - (warning #'handle-compiler-warning) - (compiler-error #'handle-compiler-error) + (handler-bind ((compiler-note #'handle-compiler-note) + (warning #'handle-compiler-warning) + (compiler-error #'handle-compiler-error) (compiler-internal-error #'handle-compiler-internal-error) (serious-condition #'handle-compiler-internal-error)) (mp:with-lock (+load-compile-lock+) @@ -205,19 +205,19 @@ (defvar *c1form-level* 0) (defun print-c1forms (form) (cond ((consp form) - (let ((*c1form-level* (1+ *c1form-level*))) - (mapc #'print-c1forms form))) - ((c1form-p form) - (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) - (print-c1forms (c1form-args form)) - form - ))) + (let ((*c1form-level* (1+ *c1form-level*))) + (mapc #'print-c1forms form))) + ((c1form-p form) + (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) + (print-c1forms (c1form-args form)) + form + ))) (defun print-ref (ref-object stream) (let ((name (ref-name ref-object))) (if name - (format stream "#" (type-of ref-object) name) - (format stream "#" (type-of ref-object))))) + (format stream "#" (type-of ref-object) name) + (format stream "#" (type-of ref-object))))) (defun print-var (var-object stream) (format stream "#" (var-name var-object) (var-kind var-object))) @@ -234,8 +234,8 @@ (defun cmperr (string &rest args) (let ((c (make-condition 'compiler-error - :format-control string - :format-arguments args))) + :format-control string + :format-arguments args))) (signal c) (print-compiler-message c t) (abort))) @@ -245,23 +245,23 @@ ;; is a circular list or terminates with a non-NIL atom. (declare (optimize (speed 3) (safety 0))) (loop with slow = l - with fast = l - with flag = t - for l of-type fixnum from 0 - do (cond ((null fast) - (return l)) - ((not (consp fast)) - (return nil)) - (flag - (setf flag nil - fast (cdr (truly-the cons fast)))) - ((eq slow fast) - (return nil)) - (t - (setf flag t - slow (cdr (truly-the cons slow)) - fast (cdr (truly-the cons fast))))) - finally (return l))) + with fast = l + with flag = t + for l of-type fixnum from 0 + do (cond ((null fast) + (return l)) + ((not (consp fast)) + (return nil)) + (flag + (setf flag nil + fast (cdr (truly-the cons fast)))) + ((eq slow fast) + (return nil)) + (t + (setf flag t + slow (cdr (truly-the cons slow)) + fast (cdr (truly-the cons fast))))) + finally (return l))) (defun check-args-number (operator args &optional (min 0) (max most-positive-fixnum)) @@ -291,8 +291,8 @@ (let ((condition (apply #'make-condition args))) (restart-case (signal condition) (muffle-warning () - :REPORT "Skip warning" - (return-from do-cmpwarn nil))) + :REPORT "Skip warning" + (return-from do-cmpwarn nil))) (print-compiler-message condition t))) (defun cmpwarn-style (string &rest args) @@ -311,7 +311,7 @@ (defun print-current-form () (when *compile-print* (let ((*print-length* 2) - (*print-level* 2)) + (*print-level* 2)) (format t "~&;;; Compiling ~s.~%" (innermost-non-expanded-form *current-toplevel-form*)))) nil) @@ -320,7 +320,7 @@ (when *compile-print* (let* ((name (or (fun-name f) (fun-description f)))) (when name - (format t "~&;;; Emitting code for ~s.~%" name))))) + (format t "~&;;; Emitting code for ~s.~%" name))))) (defun undefined-variable (sym) (do-cmpwarn 'compiler-undefined-variable :name sym)) @@ -328,14 +328,14 @@ (defun baboon (&key (format-control "A bug was found in the compiler") format-arguments) (signal 'compiler-internal-error - :format-control format-control - :format-arguments format-arguments)) + :format-control format-control + :format-arguments format-arguments)) (defmacro with-cmp-protection (main-form error-form) `(let* ((si::*break-enable* *compiler-break-enable*) (throw-flag t)) (unwind-protect - (multiple-value-prog1 + (multiple-value-prog1 (if *compiler-break-enable* (handler-bind ((error #'invoke-debugger)) ,main-form) @@ -374,7 +374,7 @@ (cmp-expand-macro fd (list* fname args) env) (serious-condition (c) (do-cmpwarn 'compiler-macro-expansion-failed - :format-control "The expansion of the compiler macro~%~T~A~%was aborted because of a serious condition~%~A" :format-arguments (list fname c)) + :format-control "The expansion of the compiler macro~%~T~A~%was aborted because of a serious condition~%~A" :format-arguments (list fname c)) (values nil nil)))) (defun si::compiler-clear-compiler-properties (symbol) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 5e56e0f5e..625fa1c85 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -18,7 +18,7 @@ (let ((var (apply #'%make-var args))) (unless (member (var-kind var) '(SPECIAL GLOBAL)) (when *current-function* - (push var (fun-local-vars *current-function*)))) + (push var (fun-local-vars *current-function*)))) var)) (defun var-referenced-in-form-list (var form-list) @@ -34,7 +34,7 @@ ;;; variable are actually called from the given node. The problem arises when ;;; we create a closure of a function, as in ;;; -;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) +;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) ;;; ;;; To know whether A is changed or read, we would have to track where B is ;;; actually used. @@ -48,9 +48,9 @@ (declare (type var var)) (or (find-form-in-node-list form (var-set-nodes var)) (let ((kind (var-kind var))) - (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) - (c1form-sp-change form) - (var-functions-setting var))))) + (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) + (c1form-sp-change form) + (var-functions-setting var))))) (defun update-variable-type (var orig-type) ;; FIXME! Refuse to update type of variables that are modified @@ -58,15 +58,15 @@ (return-from update-variable-type)) (let ((type (type-and (var-type var) orig-type))) (if (null type) - (cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A" - (var-name var) - (var-type var) - orig-type) - (loop for form in (var-read-forms var) - when (and (eq (c1form-name form) 'VAR) - (eq var (c1form-arg 0 form))) - do (setf (c1form-type form) (type-and type (c1form-primary-type form))) - finally (setf (var-type var) type))))) + (cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A" + (var-name var) + (var-type var) + orig-type) + (loop for form in (var-read-forms var) + when (and (eq (c1form-name form) 'VAR) + (eq var (c1form-arg 0 form))) + do (setf (c1form-type form) (type-and type (c1form-primary-type form))) + finally (setf (var-type var) type))))) (defun var-read-forms (var) (mapcar #'first (var-read-nodes var))) @@ -74,28 +74,28 @@ (defun assert-var-ref-value (var) #+debug-compiler (unless (let ((ref (var-ref var))) - (or (> ref (/ most-positive-fixnum 2)) - (= (var-ref var) (+ (length (var-read-nodes var)) - (length (var-set-nodes var)))))) + (or (> ref (/ most-positive-fixnum 2)) + (= (var-ref var) (+ (length (var-read-nodes var)) + (length (var-set-nodes var)))))) (baboon :format-control "Number of references in VAR ~A unequal to references list" - :format-arguments (list var)))) + :format-arguments (list var)))) (defun assert-var-not-ignored (var) (when (let ((x (var-ignorable var))) (and x (minusp x))) (cmpwarn-style "Variable ~A, declared as IGNORE, found in a lisp form." - (var-name var)) + (var-name var)) (setf (var-ignorable var) nil))) (defun delete-from-read-nodes (var form) (assert-var-ref-value var) (setf (var-ref var) (1- (var-ref var)) - (var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var)))) + (var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var)))) (defun add-to-read-nodes (var form) (assert-var-ref-value var) (assert-var-not-ignored var) (setf (var-ref var) (1+ (var-ref var)) - (var-read-nodes var) (add-form-to-node-list form (var-read-nodes var))) + (var-read-nodes var) (add-form-to-node-list form (var-read-nodes var))) (when *current-function* (unless (eq *current-function* (var-function var)) (pushnew *current-function* (var-functions-reading var)) @@ -106,7 +106,7 @@ (assert-var-ref-value var) (assert-var-not-ignored var) (setf (var-ref var) (1+ (var-ref var)) - (var-set-nodes var) (add-form-to-node-list form (var-set-nodes var))) + (var-set-nodes var) (add-form-to-node-list form (var-set-nodes var))) ;;(push form (var-read-nodes var)) (when *current-function* (unless (eq *current-function* (var-function var)) @@ -153,9 +153,9 @@ (multiple-value-bind (var ccb clb unw) (cmp-env-search-var name) (cond ((var-p var) - (var-type var)) - ((get-sysprop name 'CMP-TYPE)) - (t)))) + (var-type var)) + ((get-sysprop name 'CMP-TYPE)) + (t)))) ;;; ;;; Check if the symbol has a symbol macro @@ -173,24 +173,24 @@ (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) (let ((ignorable (cdr (assoc name ignores))) - (kind 'LEXICAL) ; we rely on check-vref to fix it + (kind 'LEXICAL) ; we rely on check-vref to fix it (type (assoc name types))) (cond ((null type) - (setq type 'T)) - ((machine-c-type-p (setq type (cdr type))) - (setf kind type - type (rep-type->lisp-type type)))) + (setq type 'T)) + ((machine-c-type-p (setq type (cdr type))) + (setf kind type + type (rep-type->lisp-type type)))) (cond ((or (member name specials) (special-variable-p name)) - (unless (eq kind 'LEXICAL) - (cmperr "Special variable ~A cannot be declared to have C type ~A" - name type)) + (unless (eq kind 'LEXICAL) + (cmperr "Special variable ~A cannot be declared to have C type ~A" + name type)) (when (eq type 'T) - (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) - (c1make-global-variable name :kind 'SPECIAL :type type)) + (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) + (c1make-global-variable name :kind 'SPECIAL :type type)) (t - (make-var :name name :type type :loc 'OBJECT - :kind kind :ignorable ignorable - :ref 0))))) + (make-var :name name :type type :loc 'OBJECT + :kind kind :ignorable ignorable + :ref 0))))) (defun check-vref (var) (when (eq (var-kind var) 'LEXICAL) @@ -200,15 +200,15 @@ (when (not (var-ref-clb var)) ;; if the variable can be stored locally, set it var-kind to its type (setf (var-kind var) - (if (plusp (var-ref var)) - (lisp-type->rep-type (var-type var)) - :OBJECT))))) + (if (plusp (var-ref var)) + (lisp-type->rep-type (var-type var)) + :OBJECT))))) (defun c1var (name) (let* ((var (c1vref name)) - (output (make-c1form* 'VAR - :type (var-type var) - :args var))) + (output (make-c1form* 'VAR + :type (var-type var) + :args var))) (add-to-read-nodes var output) output)) @@ -223,33 +223,33 @@ (make-var :kind :object :type type :loc `(TEMP ,(next-temp)))) ;;; A variable reference (vref for short) is a list: pair -;;; ( var-object ) Beppe(ccb) ccb-reference ) +;;; ( var-object ) Beppe(ccb) ccb-reference ) (defun c1vref (name) (multiple-value-bind (var ccb clb unw) (cmp-env-search-var name) (cond ((null var) - (c1make-global-variable name :warn t - :type (or (get-sysprop name 'CMP-TYPE) t))) - ((not (var-p var)) - ;; symbol-macrolet - (baboon)) - (t - (case (var-kind var) - ((SPECIAL GLOBAL)) - ((CLOSURE)) - ((LEXICAL) - (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB - (var-ref-ccb var) t - (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT)) - (clb (setf (var-ref-clb var) t - (var-loc var) 'OBJECT)))) - (t - (when (or clb ccb) - (cmperr "Variable ~A declared of C type cannot be referenced across function boundaries." - (var-name var))))) - var)))) + (c1make-global-variable name :warn t + :type (or (get-sysprop name 'CMP-TYPE) t))) + ((not (var-p var)) + ;; symbol-macrolet + (baboon)) + (t + (case (var-kind var) + ((SPECIAL GLOBAL)) + ((CLOSURE)) + ((LEXICAL) + (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (clb (setf (var-ref-clb var) t + (var-loc var) 'OBJECT)))) + (t + (when (or clb ccb) + (cmperr "Variable ~A declared of C type cannot be referenced across function boundaries." + (var-name var))))) + var)))) (defun push-vars (v) (setf (var-index v) (length (cmp-env-variables))) @@ -284,8 +284,8 @@ (LEXICAL (wt-lex var-loc)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt "ecl_symbol_value(" var-loc ")") - (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) + (wt "ecl_symbol_value(" var-loc ")") + (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) (t (wt var-loc)) ))) @@ -308,8 +308,8 @@ (wt #\;)) ((SPECIAL GLOBAL) (if (safe-compile) - (wt-nl "cl_set(" var-loc ",") - (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) + (wt-nl "cl_set(" var-loc ",") + (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) (wt-coerce-loc (var-rep-type var) loc) (wt ");")) (t @@ -329,16 +329,16 @@ ;;; ---------------------------------------------------------------------- (defun c1make-global-variable (name &key - (type (or (get-sysprop name 'CMP-TYPE) t)) - (kind 'GLOBAL) - (warn nil)) + (type (or (get-sysprop name 'CMP-TYPE) t)) + (kind 'GLOBAL) + (warn nil)) (let* ((var (make-var :name name :kind kind :type type :loc (add-symbol name)))) (when warn (unless (or (constantp name) - (special-variable-p name) - (member name *undefined-vars*)) - (undefined-variable name) - (push name *undefined-vars*))) + (special-variable-p name) + (member name *undefined-vars*)) + (undefined-variable name) + (push name *undefined-vars*))) var)) (defun c1declare-specials (globals) @@ -352,11 +352,11 @@ (let ((l (length args))) (cmpck (oddp l) "SETQ requires an even number of arguments.") (cond ((zerop l) (c1nil)) - ((= l 2) (c1setq1 (first args) (second args))) - (t - (c1progn - (loop while args - collect `(setq ,(pop args) ,(pop args)))))))) + ((= l 2) (c1setq1 (first args) (second args))) + (t + (c1progn + (loop while args + collect `(setq ,(pop args) ,(pop args)))))))) (defun c1setq1 (name form) (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) @@ -364,13 +364,13 @@ (setq name (chk-symbol-macrolet name)) (if (symbolp name) (let* ((name (c1vref name)) - (type (var-type name)) - (form (c1expr (if (trivial-type-p type) - form - `(checked-value ,type ,form))))) - (add-to-set-nodes name (make-c1form* 'SETQ - :type (c1form-type form) - :args name form))) + (type (var-type name)) + (form (c1expr (if (trivial-type-p type) + form + `(checked-value ,type ,form))))) + (add-to-set-nodes name (make-c1form* 'SETQ + :type (c1form-type form) + :args name form))) `(setf ,name ,form))) (defun c2setq (c1form vref form) @@ -386,10 +386,10 @@ (defun c1progv (args) (check-args-number 'PROGV args 2) (let ((symbols (c1expr (first args))) - (values (c1expr (second args))) - (forms (c1progn (cddr args)))) + (values (c1expr (second args))) + (forms (c1progn (cddr args)))) (make-c1form* 'PROGV :type (c1form-type forms) - :args symbols values forms))) + :args symbols values forms))) (defun c2progv (c1form symbols values body) (declare (ignore c1form)) @@ -414,15 +414,15 @@ ((endp l)) (let ((var (pop l))) (cmpck (not (symbolp var)) - "The variable ~s is not a symbol." var) + "The variable ~s is not a symbol." var) (cmpck (endp l) - "No form was given for the value of ~s." var) + "No form was given for the value of ~s." var) (setq var (chk-symbol-macrolet var)) (setq args (nconc args (list var (pop l)))) (if (symbolp var) - (cmpck (constantp var) - "The constant ~s is being assigned a value." var) - (setq use-psetf t)))) + (cmpck (constantp var) + "The constant ~s is being assigned a value." var) + (setq use-psetf t)))) (when use-psetf (return-from c1psetq `(psetf ,@args))) ;; In the second pass we compile the variable references and the @@ -432,19 +432,19 @@ (forms '())) ((endp args) (add-to-set-nodes-of-var-list - vrefs (make-c1form* 'PSETQ :type '(MEMBER NIL) - :args (reverse vrefs) (nreverse forms)))) + vrefs (make-c1form* 'PSETQ :type '(MEMBER NIL) + :args (reverse vrefs) (nreverse forms)))) (let* ((vref (c1vref (pop args))) - (type (var-type vref)) - (form (pop args))) + (type (var-type vref)) + (form (pop args))) (push vref vrefs) (push (c1expr (if (trivial-type-p type) - form - `(checked-value ,type ,form))) - forms)))) + form + `(checked-value ,type ,form))) + forms)))) (defun c2psetq (c1form vrefs forms - &aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*)) + &aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*)) (declare (ignore c1form)) ;; similar to inline-args (do ((vrefs vrefs (cdr vrefs)) @@ -452,17 +452,17 @@ (var) (form)) ((null vrefs)) (setq var (first vrefs) - form (car forms)) + form (car forms)) (if (or (var-changed-in-form-list var (rest forms)) - (var-referenced-in-form-list var (rest forms))) + (var-referenced-in-form-list var (rest forms))) (case (c1form-name form) (LOCATION (push (cons var (c1form-arg 0 form)) saves)) (otherwise (if (local var) (let* ((rep-type (var-rep-type var)) - (rep-type-c-name (rep-type->c-name rep-type)) - (temp (make-lcl-var :rep-type rep-type))) - (wt-nl-open-brace) + (rep-type-c-name (rep-type->c-name rep-type)) + (temp (make-lcl-var :rep-type rep-type))) + (wt-nl-open-brace) (wt-nl rep-type-c-name " " *volatile* temp ";") (let ((*destination* temp)) (c2expr* form)) (push (cons var temp) saves)) diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 155b2e966..1434acf70 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -38,10 +38,10 @@ (defun data-init (&optional filename) (if (and filename (probe-file filename)) (with-open-file (s filename :direction :input) - (setf *permanent-objects* (read s) - *temporary-objects* (read s))) + (setf *permanent-objects* (read s) + *temporary-objects* (read s))) (setf *permanent-objects* (make-array 128 :adjustable t :fill-pointer 0) - *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) + *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) (defun data-get-all-objects () ;; We collect all objects that are to be externalized, but filter out @@ -57,10 +57,10 @@ 0)))) #+(or) (loop for i in (nconc (map 'list #'first *permanent-objects*) - (map 'list #'first *temporary-objects*)) - collect (if (gethash i *load-objects*) - 0 - i))) + (map 'list #'first *temporary-objects*)) + collect (if (gethash i *load-objects*) + 0 + i))) (defun data-dump-array () (cond (*compiler-constants* @@ -79,51 +79,51 @@ (prin1-to-string data))) (l (length data-string))) (subseq data-string 1 (1- l)))) - (t - ""))) + (t + ""))) (defun data-c-dump (filename) (labels ((produce-strings () - ;; Only Windows has a size limit in the strings it creates. - #-windows - (let ((s (data-dump-array))) - (when (plusp (length s)) - (list s))) - #+windows - (loop with string = (data-dump-array) - with max-string-size = 65530 - with l = (length string) - for i from 0 below l by max-string-size - for this-l = (min (- l i) max-string-size) - collect (make-array this-l :displaced-to string - :element-type 'character - :displaced-index-offset i))) - (output-one-c-string (name string stream) - (let* ((*wt-string-size* 0) - (*wt-data-column* 80) - (s (with-output-to-string (stream) - (wt-filtered-data string stream)))) - (format stream "static const struct ecl_base_string ~A[] = { - (int8_t)t_base_string, 0, ecl_aet_bc, 0, - ECL_NIL, (cl_index)~D, (cl_index)~D, - (ecl_base_char*)~A };~%" - name *wt-string-size* *wt-string-size* s) - name)) - (output-c-strings (strings stream) - (format stream - "~%static const cl_object compiler_data_text[] = {~{~%(cl_object)~A,~}~%NULL};" - (loop for s in strings - for i from 1 - for name = (format nil "compiler_data_text~D" i) - collect (output-one-c-string name s stream))))) + ;; Only Windows has a size limit in the strings it creates. + #-windows + (let ((s (data-dump-array))) + (when (plusp (length s)) + (list s))) + #+windows + (loop with string = (data-dump-array) + with max-string-size = 65530 + with l = (length string) + for i from 0 below l by max-string-size + for this-l = (min (- l i) max-string-size) + collect (make-array this-l :displaced-to string + :element-type 'character + :displaced-index-offset i))) + (output-one-c-string (name string stream) + (let* ((*wt-string-size* 0) + (*wt-data-column* 80) + (s (with-output-to-string (stream) + (wt-filtered-data string stream)))) + (format stream "static const struct ecl_base_string ~A[] = { + (int8_t)t_base_string, 0, ecl_aet_bc, 0, + ECL_NIL, (cl_index)~D, (cl_index)~D, + (ecl_base_char*)~A };~%" + name *wt-string-size* *wt-string-size* s) + name)) + (output-c-strings (strings stream) + (format stream + "~%static const cl_object compiler_data_text[] = {~{~%(cl_object)~A,~}~%NULL};" + (loop for s in strings + for i from 1 + for name = (format nil "compiler_data_text~D" i) + collect (output-one-c-string name s stream))))) (with-open-file (stream filename :direction :output :if-does-not-exist :create - :if-exists :supersede :external-format :default) + :if-exists :supersede :external-format :default) (let ((strings (produce-strings))) - (if strings - (output-c-strings strings stream) - (princ "#define compiler_data_text NULL" stream)) - ;; Ensure a final newline or some compilers complain - (terpri stream))))) + (if strings + (output-c-strings strings stream) + (princ "#define compiler_data_text NULL" stream)) + ;; Ensure a final newline or some compilers complain + (terpri stream))))) (defun data-empty-loc () (add-object 0 :duplicate t :permanent t)) @@ -131,55 +131,55 @@ (defun add-load-form (object location) (when (clos::need-to-make-load-form-p object *cmp-env*) (if (not (eq *compiler-phase* 't1)) - (cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*) - (multiple-value-bind (make-form init-form) (make-load-form object) - (setf (gethash object *load-objects*) location) - (when make-form - (push (make-c1form* 'MAKE-FORM :args location (c1expr make-form)) *make-forms*)) - (when init-form - (push (make-c1form* 'INIT-FORM :args location (c1expr init-form)) *make-forms*)))))) + (cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*) + (multiple-value-bind (make-form init-form) (make-load-form object) + (setf (gethash object *load-objects*) location) + (when make-form + (push (make-c1form* 'MAKE-FORM :args location (c1expr make-form)) *make-forms*)) + (when init-form + (push (make-c1form* 'INIT-FORM :args location (c1expr init-form)) *make-forms*)))))) (defun add-object (object &key (duplicate nil) - (permanent (or (symbolp object) *permanent-data*)) - (used-p nil)) + (permanent (or (symbolp object) *permanent-data*)) + (used-p nil)) ;; FIXME! Currently we have two data vectors and, when compiling ;; files, it may happen that a constant is duplicated and stored ;; both in VV and VVtemp. This would not be a problem if the ;; constant were readable, but due to using MAKE-LOAD-FORM we may ;; end up having two non-EQ objects created for the same value. (let* ((test (if *compiler-constants* 'eq 'equal)) - (array (if permanent *permanent-objects* *temporary-objects*)) - (x (or (and (not permanent) - (find object *permanent-objects* :test test - :key #'first)) - (find object array :test test :key #'first))) - (next-ndx (length array)) + (array (if permanent *permanent-objects* *temporary-objects*)) + (x (or (and (not permanent) + (find object *permanent-objects* :test test + :key #'first)) + (find object array :test test :key #'first))) + (next-ndx (length array)) (forced duplicate) - found) + found) (setq x - (cond ((add-static-constant object)) - ((and x duplicate) - (setq x (make-vv :location next-ndx :used-p forced - :permanent-p permanent - :value object - :used-p t)) - (vector-push-extend (list object x next-ndx) array) - x) - (x - (second x)) - ((and (not duplicate) - (symbolp object) - (multiple-value-setq (found x) (si::mangle-name object))) - x) - (t - (setq x (make-vv :location next-ndx :used-p forced - :permanent-p permanent - :value object - :used-p used-p)) - (vector-push-extend (list object x next-ndx) array) - (unless *compiler-constants* - (add-load-form object x)) - x))) + (cond ((add-static-constant object)) + ((and x duplicate) + (setq x (make-vv :location next-ndx :used-p forced + :permanent-p permanent + :value object + :used-p t)) + (vector-push-extend (list object x next-ndx) array) + x) + (x + (second x)) + ((and (not duplicate) + (symbolp object) + (multiple-value-setq (found x) (si::mangle-name object))) + x) + (t + (setq x (make-vv :location next-ndx :used-p forced + :permanent-p permanent + :value object + :used-p used-p)) + (vector-push-extend (list object x next-ndx) array) + (unless *compiler-constants* + (add-load-form object x)) + x))) (when (and used-p (typep x 'vv)) (setf (vv-used-p x) t)) x)) @@ -196,13 +196,13 @@ ;; We search for keyword lists that are similar. However, the list ;; *OBJECTS* contains elements in decreasing order!!! (let ((x (search keywords *permanent-objects* - :test #'(lambda (k record) (eq k (first record)))))) + :test #'(lambda (k record) (eq k (first record)))))) (if x (second (elt *permanent-objects* x)) - (prog1 - (add-object (pop keywords) :duplicate t :permanent t) - (dolist (k keywords) - (add-object k :duplicate t :permanent t)))))) + (prog1 + (add-object (pop keywords) :duplicate t :permanent t) + (dolist (k keywords) + (add-object k :duplicate t :permanent t)))))) ;;; ====================================================================== ;;; @@ -216,54 +216,54 @@ (defun static-single-float-builder (name value stream) (let* ((*read-default-float-format* 'single-float) - (*print-readably* t)) + (*print-readably* t)) (format stream "ecl_def_ct_single_float(~A,~S,static,const);" - name value stream))) + name value stream))) (defun static-double-float-builder (name value stream) (let* ((*read-default-float-format* 'double-float) - (*print-readably* t)) + (*print-readably* t)) (format stream "ecl_def_ct_double_float(~A,~S,static,const);" - name value stream))) + name value stream))) #+long-float (defun static-long-float-builder (name value stream) (let* ((*read-default-float-format* 'long-float) - (*print-readably* t)) + (*print-readably* t)) (format stream "ecl_def_ct_long_float(~A,~SL,static,const);" - name value stream))) + name value stream))) (defun static-rational-builder (name value stream) (let* ((*read-default-float-format* 'double-float) - (*print-readably* t)) + (*print-readably* t)) (format stream - "ecl_def_ct_ratio(~A,ecl_make_fixnum(~D),ecl_make_fixnum(~D),static,const);" - name (numerator value) (denominator value)))) + "ecl_def_ct_ratio(~A,ecl_make_fixnum(~D),ecl_make_fixnum(~D),static,const);" + name (numerator value) (denominator value)))) (defun static-constant-delegate (name value stream) (funcall (static-constant-expression value) - name value stream)) + name value stream)) (defun static-complex-builder (name value stream) (let* ((*read-default-float-format* 'double-float) - (*print-readably* t) - (name-real (concatenate 'string name "_real")) - (name-imag (concatenate 'string name "_imag"))) + (*print-readably* t) + (name-real (concatenate 'string name "_real")) + (name-imag (concatenate 'string name "_imag"))) (static-constant-delegate name-real (realpart value) stream) (terpri stream) (static-constant-delegate name-imag (imagpart value) stream) (terpri stream) (format stream - "ecl_def_ct_complex(~A,&~A_data,&~A_data,static,const);" - name name-real name-imag))) + "ecl_def_ct_complex(~A,&~A_data,&~A_data,static,const);" + name name-real name-imag))) #+sse2 (defun static-sse-pack-builder (name value stream) (let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8))) - (type-code (nth-value 1 (ext:sse-pack-element-type value)))) + (type-code (nth-value 1 (ext:sse-pack-element-type value)))) (format stream - "ecl_def_ct_sse_pack(~A,~A~{,~A~});" - name type-code (coerce bytes 'list)))) + "ecl_def_ct_sse_pack(~A,~A~{,~A~});" + name type-code (coerce bytes 'list)))) (defun static-constant-builder (format value) (lambda (name stream) @@ -273,21 +273,21 @@ (typecase object (base-string #'static-base-string-builder) (ratio (and (static-constant-expression (numerator object)) - (static-constant-expression (denominator object)) - #'static-rational-builder)) + (static-constant-expression (denominator object)) + #'static-rational-builder)) (single-float (and (not (ext:float-nan-p object)) - (not (ext:float-infinity-p object)) - #'static-single-float-builder)) + (not (ext:float-infinity-p object)) + #'static-single-float-builder)) (double-float (and (not (ext:float-nan-p object)) - (not (ext:float-infinity-p object)) - #'static-double-float-builder)) + (not (ext:float-infinity-p object)) + #'static-double-float-builder)) #+long-float (long-float (and (not (ext:float-nan-p object)) - (not (ext:float-infinity-p object)) - #'static-long-float-builder)) + (not (ext:float-infinity-p object)) + #'static-long-float-builder)) (complex (and (static-constant-expression (realpart object)) - (static-constant-expression (imagpart object)) - #'static-complex-builder)) + (static-constant-expression (imagpart object)) + #'static-complex-builder)) #+sse2 (ext:sse-pack #'static-sse-pack-builder) (t nil))) diff --git a/src/cmp/defsys.lsp.in b/src/cmp/defsys.lsp.in index 1f95d30b9..200c16891 100644 --- a/src/cmp/defsys.lsp.in +++ b/src/cmp/defsys.lsp.in @@ -1,41 +1,41 @@ ;;; ---------------------------------------------------------------------- -;;; CLOS +;;; CLOS ;;; ---------------------------------------------------------------------- (defparameter *cmp-modules* - ;; file load compile files which force - ;; environment environment recompilations of - ;; this file + ;; file load compile files which force + ;; environment environment recompilations of + ;; this file '( - (cmpdefs () () ()) - (cmpmac () () ()) - (cmpinline () () ()) - (cmputil () () ()) - (cmptype () () ()) - (cmpbind () () ()) - (cmpblock () () ()) - (cmpcall () () ()) - (cmpcatch () () ()) - (cmpenv () () ()) - (cmpeval () () ()) - (cmpexit () () ()) - (cmpflet () () ()) - (cmpfun () () ()) - (cmpif () () ()) - (cmplam () () ()) - (cmplet () () ()) - (cmploc () () ()) - (cmpmap () () ()) - (cmpmulti () () ()) - (cmpspecial () () ()) - (cmptag () () ()) - (cmptop () () ()) - (cmpvar () () ()) - (cmpwt () () ()) - (cmpmain () () ()) - (cmpffi () () ()) - (cmpcfg () () ()))) + (cmpdefs () () ()) + (cmpmac () () ()) + (cmpinline () () ()) + (cmputil () () ()) + (cmptype () () ()) + (cmpbind () () ()) + (cmpblock () () ()) + (cmpcall () () ()) + (cmpcatch () () ()) + (cmpenv () () ()) + (cmpeval () () ()) + (cmpexit () () ()) + (cmpflet () () ()) + (cmpfun () () ()) + (cmpif () () ()) + (cmplam () () ()) + (cmplet () () ()) + (cmploc () () ()) + (cmpmap () () ()) + (cmpmulti () () ()) + (cmpspecial () () ()) + (cmptag () () ()) + (cmptop () () ()) + (cmpvar () () ()) + (cmpwt () () ()) + (cmpmain () () ()) + (cmpffi () () ()) + (cmpcfg () () ()))) (sbt:defsystem cmp diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index c1ef62678..8dbb2c287 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -8,8 +8,8 @@ ;;; ;;; The function proclamations are created with PROCLAIM-FUNCTION, as in ;;; -;;; (PROCLAMATION function-name ([arg-type]*) return-type -;;; &rest {:no-sp-change|:pure|:reader|:no-side-effects}) +;;; (PROCLAMATION function-name ([arg-type]*) return-type +;;; &rest {:no-sp-change|:pure|:reader|:no-side-effects}) ;;; ;;; with the following interpretation: ARG-TYPE and RETURN-TYPE denote the most ;;; general types for the input and output values of this function. If the diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 831fed3eb..9789ab361 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -9,8 +9,8 @@ ;;; ;;; DATABASE OF INLINE EXPANSIONS ;;; -;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type -;;; expansion-string) +;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type +;;; expansion-string) ;;; ;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, ;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the @@ -138,7 +138,7 @@ "(#0)->array.self.fix[#1]= #2") (def-inline si:copy-subarray :always (array ext:array-index array ext:array-index - ext:array-index) array + ext:array-index) array "@0;(ecl_copy_subarray(#0,#1,#2,#3,#4),#0)") (def-inline array-rank :unsafe (array) :fixnum @@ -810,27 +810,27 @@ (defun def-inline (name safety arg-types return-rep-type expansion &key (one-liner t) (exact-return-type nil) (inline-or-warn nil) - (multiple-values t) + (multiple-values t) &aux arg-rep-types) (setf safety - (case safety - (:unsafe :inline-unsafe) - (:safe :inline-safe) - (:always :inline-always) - (t (error "In DEF-INLINE, wrong value of SAFETY")))) + (case safety + (:unsafe :inline-unsafe) + (:safe :inline-safe) + (:always :inline-always) + (t (error "In DEF-INLINE, wrong value of SAFETY")))) ;; Ensure we can inline this form. We only inline when the features are ;; there (checked above) and when the C types are part of this machine ;; (checked here). (loop for type in (list* return-rep-type arg-types) unless (or (eq type 'fixnum-float) - (and (consp type) (eq (car type) 'values)) - (lisp-type-p type) - (machine-c-type-p type)) + (and (consp type) (eq (car type) 'values)) + (lisp-type-p type) + (machine-c-type-p type)) do (warn "Dropping inline form for ~A because of missing type ~A" name type) (return-from def-inline)) (setf arg-rep-types - (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) - arg-types)) + (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) + arg-types)) (when (eq return-rep-type t) (setf return-rep-type :object)) (when inline-or-warn @@ -846,7 +846,7 @@ :return-type return-type :arg-types arg-types :exact-return-type exact-return-type - :multiple-values multiple-values + :multiple-values multiple-values ;; :side-effects (not (get-sysprop name 'no-side-effects)) :one-liner one-liner :expansion expansion))) @@ -1015,7 +1015,7 @@ format-general format-dollars format-relative-tab format-absolute-tab format-justification - ) + ) #+clos ,@'(;; defclass.lsp clos::ensure-class diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 773fe996e..7663289ff 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -1,12 +1,12 @@ ;;; @configure_input@ ;;; ;;; This is the "makefile" file for building ECL. The purpose of this file is -;;; - Compile the core of the Common-Lisp library (lsp, clos) -;;; - Compile the compiler (cmp) -;;; - Build an executable +;;; - Compile the core of the Common-Lisp library (lsp, clos) +;;; - Compile the compiler (cmp) +;;; - Build an executable ;;; This can be done in two ways: -;;; - Using interpreted code and the ECL_MIN minimal environment. -;;; - On a second stage, using the final ECL executable, to test it. +;;; - Using interpreted code and the ECL_MIN minimal environment. +;;; - On a second stage, using the final ECL executable, to test it. ;;; (progn @@ -26,11 +26,11 @@ (let ((*standard-output* (make-broadcast-stream))) (dolist (p '("CL" "SI" "EXT" "CLOS")) (do-symbols (s (find-package p)) - (when (and (fboundp s) - (not (typep (fdefinition s) '(or list generic-function))) - (si::mangle-name s) - (si::bc-disassemble (fdefinition s))) - (pushnew s wrong-symbols))))) + (when (and (fboundp s) + (not (typep (fdefinition s) '(or list generic-function))) + (si::mangle-name s) + (si::bc-disassemble (fdefinition s))) + (pushnew s wrong-symbols))))) (format t "~%;;; Functions that can be made into the core:~%") (pprint (set-difference wrong-symbols c::*in-all-symbols-functions*))) @@ -102,18 +102,18 @@ (mapc #'proclaim +ecl-optimization-settings+) (let* ((c::*cc-flags* (concatenate 'string "-DECL_API -I\"@true_builddir@/c\" " c::*cc-flags*)) (lsp-objects (compile-if-old "build:lsp;" +lisp-module-files+ - :system-p t :c-file t :data-file t :h-file t - ;;:shared-data-file "build:ecl.sdat" - ))) + :system-p t :c-file t :data-file t :h-file t + ;;:shared-data-file "build:ecl.sdat" + ))) #+CLOS (let* ((c::*compile-to-linking-call* nil)) (mapc #'proclaim +ecl-optimization-settings+) (setq lsp-objects (append lsp-objects - (compile-if-old "build:clos;" +clos-module-files+ - :system-p t :c-file t :data-file t + (compile-if-old "build:clos;" +clos-module-files+ + :system-p t :c-file t :data-file t :h-file t - ;;:shared-data-file "build:ecl.sdat" - )))) + ;;:shared-data-file "build:ecl.sdat" + )))) (let ((extra-lisp-files '(@ECL_EXTRA_LISP_FILES@))) (when extra-lisp-files (setq lsp-objects (append lsp-objects @@ -123,12 +123,12 @@ ;;:shared-data-file "build:ecl.sdat" ))))) (c::build-static-library "lsp" :lisp-files lsp-objects - ;;:shared-data-file "build:ecl.sdat" - )) + ;;:shared-data-file "build:ecl.sdat" + )) #-:wants-dlopen (c::safe-system - (concatenate 'string + (concatenate 'string "sh -c 'rm -rf tmp; mkdir tmp;" "cp @LIBPREFIX@eclmin.@LIBEXT@ @LIBPREFIX@ecl.@LIBEXT@;" "cd tmp; ar -x ../@LIBPREFIX@lsp.@LIBEXT@;" @@ -141,7 +141,7 @@ ;;; We do not need the -rpath flag for the library, nor -lecl. ;;; (let* ((c::*ld-shared-flags* #-msvc "@SHARED_LDFLAGS@ @LDFLAGS@ @SONAME_LDFLAGS@ @CORE_LIBS@ @FASL_LIBS@ @LIBS@" - #+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ @STATICLIBS@ @CLIBS@") + #+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ @STATICLIBS@ @CLIBS@") (c::*cc-flags* (concatenate 'string "-DECL_API -I@true_builddir@/c " c::*cc-flags*)) (extra-args nil)) #+(or mingw32 cygwin) @@ -235,8 +235,8 @@ :dir "build:ext;" :prefix "EXT" :builtin - #+(or (NOT :WANTS-DLOPEN) :BUILTIN-PROFILE) t - #-(or (NOT :WANTS-DLOPEN) :BUILTIN-PROFILE) nil) + #+(or (NOT :WANTS-DLOPEN) :BUILTIN-PROFILE) t + #-(or (NOT :WANTS-DLOPEN) :BUILTIN-PROFILE) nil) ;;; ;;; * Sockets library. @@ -244,67 +244,67 @@ #+WANTS-SOCKETS (build-module "sockets" - '("ext:sockets;package.lisp" - "ext:sockets;sockets.lisp") - :dir "build:ext;" - :prefix "EXT" + '("ext:sockets;package.lisp" + "ext:sockets;sockets.lisp") + :dir "build:ext;" + :prefix "EXT" :builtin - #+(or (NOT :WANTS-DLOPEN) :BUILTIN-SOCKETS) t - #-(or (NOT :WANTS-DLOPEN) :BUILTIN-SOCKETS) nil) + #+(or (NOT :WANTS-DLOPEN) :BUILTIN-SOCKETS) t + #-(or (NOT :WANTS-DLOPEN) :BUILTIN-SOCKETS) nil) #+WANTS-SOCKETS (build-module "sb-bsd-sockets" - '("ext:sockets;sb-bsd-sockets.lisp") + '("ext:sockets;sb-bsd-sockets.lisp") :depends-on '("sockets") - :dir "build:ext;" - :prefix "EXT" - :builtin nil) + :dir "build:ext;" + :prefix "EXT" + :builtin nil) #+WANTS-SERVE-EVENT (build-module "serve-event" - '("ext:serve-event;serve-event.lisp") - :dir "build:ext;" - :prefix "EXT" + '("ext:serve-event;serve-event.lisp") + :dir "build:ext;" + :prefix "EXT" :builtin - #+(or (NOT :WANTS-DLOPEN) :BUILTIN-SERVE-EVENT) t - #-(or (NOT :WANTS-DLOPEN) :BUILTIN-SERVE-EVENT) nil) + #+(or (NOT :WANTS-DLOPEN) :BUILTIN-SERVE-EVENT) t + #-(or (NOT :WANTS-DLOPEN) :BUILTIN-SERVE-EVENT) nil) #+WANTS-SOCKETS (build-module "ecl-curl" - '("ext:ecl-curl;ecl-curl.lisp") - :dir "build:ext;" - :prefix "EXT" - :builtin nil) + '("ext:ecl-curl;ecl-curl.lisp") + :dir "build:ext;" + :prefix "EXT" + :builtin nil) #+WANTS-SOCKETS (build-module "ql-minitar" - '("ext:quicklisp;minitar.lisp") - :dir "build:ext;" - :prefix "EXT" - :builtin nil) + '("ext:quicklisp;minitar.lisp") + :dir "build:ext;" + :prefix "EXT" + :builtin nil) #+WANTS-SOCKETS (build-module "deflate" - '("ext:deflate;deflate.lisp") - :dir "build:ext;" - :prefix "EXT" - :builtin nil) + '("ext:deflate;deflate.lisp") + :dir "build:ext;" + :prefix "EXT" + :builtin nil) #+WANTS-SOCKETS (build-module "ecl-quicklisp" - '("ext:quicklisp;ecl-quicklisp.lisp") - :dir "build:ext;" - :prefix "EXT" - :builtin nil) + '("ext:quicklisp;ecl-quicklisp.lisp") + :dir "build:ext;" + :prefix "EXT" + :builtin nil) ;;; ;;; * Test suite ;;; #+WANTS-RT (build-module "rt" - '("ext:rt;rt.lisp") - :dir "build:ext;" - :prefix "EXT" + '("ext:rt;rt.lisp") + :dir "build:ext;" + :prefix "EXT" :builtin #+:BUILTIN-RT t #-:BUILTIN-RT nil) ;;; @@ -349,21 +349,21 @@ "src:clx;xtest.lisp" "src:clx;screensaver.lisp" "src:clx;xinerama.lisp" - "build:clx;module.lisp")) + "build:clx;module.lisp")) #+:msvc (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150"))) (let ((filename "build:clx;module.lisp")) (ensure-directories-exist filename) (with-open-file (s filename :direction :output :if-exists :overwrite - :if-does-not-exist :create) + :if-does-not-exist :create) (print '(provide :clx) s))) (unless (find-package "SB-BSD-SOCKETS") (load "ext:sockets;package.lisp")) (mapcar #'load +clx-src-files+) (build-module "clx" +clx-src-files+ :dir "build:clx;" :prefix "CLX" - :builtin - #+(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) t - #-(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) nil)) + :builtin + #+(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) t + #-(OR (NOT :WANTS-DLOPEN) :BUILTIN-CLX) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -397,8 +397,8 @@ (concatenate 'list #-msvc '("-L./") #+windows '("ecl.res" #+msvc "/F 10485760"))) (with-open-file (modules-list #P"build:MODULES" :direction :output - :if-exists :supersede - :if-does-not-exist :create) + :if-exists :supersede + :if-does-not-exist :create) (print *module-files*) (dolist (module-file *module-files*) (format modules-list "~A~%" module-file))) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 2a8b41817..c1d518e98 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -12,7 +12,7 @@ ;;;; ;;;; Sets doc-strings for built-in symbols. -(in-package "COMPILER") ; in case it does not exist +(in-package "COMPILER") ; in case it does not exist (in-package "SYSTEM") (defmacro docfun (symbol kind args doc) @@ -23,23 +23,23 @@ (assert (listp args)) (ext:annotate symbol ':lambda-list nil args) (cond ((and doc (search "Syntax:" doc)) - (setf args nil)) - ((and doc (search "Args:" doc)) - (setf args nil)) - ((member kind '(macro special)) - (setf args (format nil "Syntax: ~A" args))) - (t - (setf args (format nil "Args: ~A" args)))) + (setf args nil)) + ((and doc (search "Args:" doc)) + (setf args nil)) + ((member kind '(macro special)) + (setf args (format nil "Syntax: ~A" args))) + (t + (setf args (format nil "Args: ~A" args)))) (si::set-documentation symbol 'function (format nil "~A in ~A package:~@[~%~A~]~@[~%~A~]~%" - (ecase kind - (special "Special Form") - (macro "Macro") - (function "Function") - (method "Generic function")) - (package-name (symbol-package (si::function-block-name symbol))) - args doc))) + (ecase kind + (special "Special Form") + (macro "Macro") + (function "Function") + (method "Generic function")) + (package-name (symbol-package (si::function-block-name symbol))) + args doc))) (defmacro docvar (symbol kind doc) (do-docvar symbol kind doc)) @@ -49,7 +49,7 @@ (si::set-documentation symbol 'variable (format nil "~@(~A~) in ~A package:~A~%" - kind (package-name (symbol-package symbol)) doc))) + kind (package-name (symbol-package symbol)) doc))) (defmacro doctype (symbol doc) (do-doctype symbol doc)) @@ -60,34 +60,34 @@ (defun tree-search (tree x) (cond ((eq tree x) - t) - ((atom tree) - nil) - ((tree-search (car tree) x) - t) - (t - (tree-search (cdr tree) x)))) + t) + ((atom tree) + nil) + ((tree-search (car tree) x) + t) + (t + (tree-search (cdr tree) x)))) (defun our-pde-hook (location definition output-form) (when (consp definition) (handler-case - (let* ((documentation nil) - (name (second definition))) - (loop for i in (cddr definition) - do (cond ((stringp i) - (setf documentation i) - (return)) - ((and (consp i) (eq (first i) 'DECLARE)) - ;; Produce no documentation for si::c-local functions - (when (tree-search i 'si::c-local) - (return-from our-pde-hook output-form))) - (t (return)))) - (case (first definition) - (defun (do-docfun name 'function (third definition) documentation)) - (defmacro (do-docfun name 'macro (third definition) documentation)) - ((defvar defparameter) (when documentation (do-docvar name 'variable documentation))) - (defconstant (when documentation (do-docvar name 'constant documentation))) - (deftype (when documentation (do-doctype name documentation))))) + (let* ((documentation nil) + (name (second definition))) + (loop for i in (cddr definition) + do (cond ((stringp i) + (setf documentation i) + (return)) + ((and (consp i) (eq (first i) 'DECLARE)) + ;; Produce no documentation for si::c-local functions + (when (tree-search i 'si::c-local) + (return-from our-pde-hook output-form))) + (t (return)))) + (case (first definition) + (defun (do-docfun name 'function (third definition) documentation)) + (defmacro (do-docfun name 'macro (third definition) documentation)) + ((defvar defparameter) (when documentation (do-docvar name 'variable documentation))) + (defconstant (when documentation (do-docvar name 'constant documentation))) + (deftype (when documentation (do-doctype name documentation))))) (error (c) (princ c) (quit)))) output-form) @@ -96,7 +96,7 @@ #|| (defmacro docfun (symbol kind args string) `(progn (si::putprop ',symbol ,string 'si::function-documentation) - (si::putprop ',symbol ',args 'arglist) + (si::putprop ',symbol ',args 'arglist) ',symbol)) (defmacro docvar (symbol kind string) @@ -110,7 +110,7 @@ ||# ;;;---------------------------------------------------------------------- -;;; Ordered alphabetically for binary search +;;; Ordered alphabetically for binary search ;;;---------------------------------------------------------------------- (docvar + variable " @@ -163,21 +163,21 @@ synonym stream to *TERMINAL-IO*.") List of symbols that name features of the current version of ECL. These features are used in connection with the read macros #+ and #-. When the reader encounters - #+ feature-spec form + #+ feature-spec form it reads FORM in the usual manner if FEATURE-SPEC is satisfied. Otherwise, the reader just skips FORM. - #- feature-spec form + #- feature-spec form is equivalent to - #- (not feature-spec) form + #- (not feature-spec) form A feature-spec may be a symbol, in which case the spec is satisfied iff the symbol is an element of *FEATURES*. Or else, a feature-spec must be one of the following forms. - (and {feature-spec}*) - Satisfied iff all FEATURE-SPECs are satisfied - (or {feature-spec}*) - Satisfied iff at least one of FEATURE-SPECs is satisfied - (not feature-spec) - Satisfied iff FEATURE-SPEC is not satisfied") + (and {feature-spec}*) + Satisfied iff all FEATURE-SPECs are satisfied + (or {feature-spec}*) + Satisfied iff at least one of FEATURE-SPECs is satisfied + (not feature-spec) + Satisfied iff FEATURE-SPEC is not satisfied") #-boehm-gc (docvar si::*gc-message* variable " @@ -241,9 +241,9 @@ It initial value is T.") (docvar *macroexpand-hook* variable " The value of this variable must be a three-argument function object. Each time a macro form is expanded, ECL calls that function with - 1. the macro expansion function (see MACRO-FUNCTION) - 2. the macro form to expand - 3. an environment (NIL in most case) + 1. the macro expansion function (see MACRO-FUNCTION) + 2. the macro form to expand + 3. an environment (NIL in most case) as three arguments, and uses the returned value as the expanded form. The initial value of this variable is the function FUNCALL.") @@ -262,9 +262,9 @@ The current package. The initial value is the USER package.") (docvar *print-array* variable " Specifies whether ECL should print elements when it prints arrays other than strings. ECL uses the following abbreviation notations. - # for bit-vectors - # for vectors other than strings and bit-vectors - # for arrays other than vectors + # for bit-vectors + # for vectors other than strings and bit-vectors + # for arrays other than vectors where N is a number that identifies the array.") (docvar *print-base* variable " @@ -273,9 +273,9 @@ from 2 to 36, inclusive. The initial value is 10.") (docvar *print-case* variable " Specifies how to print ordinary symbols. Possible values are: - :UPCASE in upper case - :DOWNCASE in lower case - :CAPITALIZE the first character in upper case, the rest in lower + :UPCASE in upper case + :DOWNCASE in lower case + :CAPITALIZE the first character in upper case, the rest in lower The initial value is :UPCASE.") (docvar *print-circle* variable " @@ -468,7 +468,7 @@ Returns the N-th argument given in the command line that invoked ECL.") (doctype array " An array is a compound object whose elements are referenced by indexing. One- dimensional arrays are called vectors. Other arrays are notated as - #?a( ... ) or #?A( ... ) + #?a( ... ) or #?A( ... ) where '?' is actually the rank of the array. Arrays may be displaced to another array, may have a fill-pointer, or may be adjustable. Other arrays are called simple-arrays. Only simple-arrays can be @@ -542,19 +542,19 @@ VALUE-FORM will be returned as the values of the terminated BLOCK form.") (docfun boole function (op integer1 integer2) " Returns the integer produced by the logical operation specified by OP on the two integers. OP must be the value of one of the following constants. - BOOLE-CLR BOOLE-C1 BOOLE-XOR BOOLE-ANDC1 - BOOLE-SET BOOLE-C2 BOOLE-EQV BOOLE-ANDC2 - BOOLE-1 BOOLE-AND BOOLE-NAND BOOLE-ORC1 - BOOLE-2 BOOLE-IOR BOOLE-NOR BOOLE-ORC2 + BOOLE-CLR BOOLE-C1 BOOLE-XOR BOOLE-ANDC1 + BOOLE-SET BOOLE-C2 BOOLE-EQV BOOLE-ANDC2 + BOOLE-1 BOOLE-AND BOOLE-NAND BOOLE-ORC1 + BOOLE-2 BOOLE-IOR BOOLE-NOR BOOLE-ORC2 Each logical operation on integers produces an integer represented by the bit sequence obtained by a bit-wise logical operation on the bit sequences that represent the integers. Two's-complement representation is assumed to obtain the bit sequence that represents an integer. For example, - 2: ...010 - 1: ...001 - 0: ...000 - -1: ...111 - -2: ...110 + 2: ...010 + 1: ...001 + 0: ...000 + -1: ...111 + -2: ...110 where each '...' represents either an infinite sequence of 0's (for non- negative integers) or an infinite sequence of 1's (for negative integers).") @@ -629,8 +629,8 @@ library of FASL code. You should use symbols to call in optional parts of the interpreter, such as the compiler 'CMP or the 'CLX library (not yet available) For example: - (compile-file \"my-code.lsp\" :system-p) - (build-ecl \"my-ecl\" \"my-code.o\" \"-Bdynamic -lX11\" 'cmp) + (compile-file \"my-code.lsp\" :system-p) + (build-ecl \"my-ecl\" \"my-code.o\" \"-Bdynamic -lX11\" 'cmp) builds an new interpreter with some custom lisp code given in \"my-code.o\" and with the ECL compiler (You must explicitely mention the compiler if you want it). Finally, the X-Windows dynamically linked libraries are also included @@ -879,17 +879,17 @@ otherwise.") A character represents a character that can be handled by the computer. Characters have font, bits, and code attributes. Font and bits attributes are always 0 in ECL. Most versions of ECL uses ASCII code: - 000 - 037 #\\^@ #\\^A #^B ... #\\Z #\\^[ #\\^\\ #\\^] #\\^^ #\\^_ - except #\\Tab(011) #\\Newline(012) #\\Page(014) - #\\Return(015) #\\Backspace(031) - 040 - 057 #\\Space #\\! #\\\" #\\# #\\$ #\\% #\\& #\\' #\\( #\\) #\\* - #\\+ #\\, #\\- #\\. #\\/ - 060 - 071 #\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9 - 072 - 100 #\\: #\\; #\\< #\\= #\\> #\\? #\\@ - 101 - 132 #\\A ... #\\Z - 133 - 140 #\\[ #\\\\ #\\] #\\^ #\\_ #\\` - 141 - 172 #\\a ... #\\z - 173 - 177 #\\{ #\\| #\\} #\\~~ #\\Rubout + 000 - 037 #\\^@ #\\^A #^B ... #\\Z #\\^[ #\\^\\ #\\^] #\\^^ #\\^_ + except #\\Tab(011) #\\Newline(012) #\\Page(014) + #\\Return(015) #\\Backspace(031) + 040 - 057 #\\Space #\\! #\\\" #\\# #\\$ #\\% #\\& #\\' #\\( #\\) #\\* + #\\+ #\\, #\\- #\\. #\\/ + 060 - 071 #\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9 + 072 - 100 #\\: #\\; #\\< #\\= #\\> #\\? #\\@ + 101 - 132 #\\A ... #\\Z + 133 - 140 #\\[ #\\\\ #\\] #\\^ #\\_ #\\` + 141 - 172 #\\a ... #\\z + 173 - 177 #\\{ #\\| #\\} #\\~~ #\\Rubout Some versions of ECL support additional characters to represent Japanese character set.") @@ -958,8 +958,8 @@ Returns T if X is a Common Lisp object; NIL otherwise.") (doctype compiled-function " A compiled function is an object that is created by compiling a function. A compiled function is notated in either of the following formats: - # - # + # + # where S is actually the symbol that names the function.") (docfun si::compiled-function-name function (compiled-function) " @@ -970,7 +970,7 @@ Returns the function name associated with COMPILED-FUNCTION.") Returns T if X is a compiled function object; NIL otherwise.") (docfun compiler-let special (bindings &body forms) - "Syntax: (compiler-let ({var | (var [value])}*) {form}*) + "Syntax: (compiler-let ({var | (var [value])}*) {form}*) When interpreted, this form works just like a LET form with all VARs declared special. When compiled, FORMs are processed with the VARs bound at compile @@ -979,7 +979,7 @@ time, but no bindings occur when the compiled code is executed.") (doctype complex " A complex number represents a complex number in mathematical sense, consisting of a real part and an imaginary part. A complex number is notated as - #c( realpart imagpart ) or #C( realpart imagpart ) + #c( realpart imagpart ) or #C( realpart imagpart ) where REALPART and IMAGPART are non-complex numbers.") (docfun complex function (realpart &optional (imagpart 0)) " @@ -1027,10 +1027,10 @@ symbol gets a copy of the property list of SYMBOL.") (docfun copy-tree function (tree) " Returns a copy of TREE. Defined as: - (defun copy-tree (tree) - (if (atom tree) - tree - (cons (copy-tree (car tree)) (copy-tree (cdr tree)))))") + (defun copy-tree (tree) + (if (atom tree) + tree + (cons (copy-tree (car tree)) (copy-tree (cdr tree)))))") (docfun cos function (radians) " Returns the cosine of RADIANS.") @@ -1060,17 +1060,17 @@ Gives declarations. Possible DECL-SPECs are: (SPECIAL {var}*) (TYPE type {var}*) (type {var}*) where 'type' is one of the following symbols - array fixnum package simple-string - atom float pathname simple-vector - bignum function random-state single-float - bit hash-table ratio standard-char - bit-vector integer rational stream - character keyword readtable string - common list sequence string-char - compiled-function long-float short-float symbol - complex nil signed-byte t - cons null simple-array unsigned-byte - double-float number simple-bit-vector vector + array fixnum package simple-string + atom float pathname simple-vector + bignum function random-state single-float + bit hash-table ratio standard-char + bit-vector integer rational stream + character keyword readtable string + common list sequence string-char + compiled-function long-float short-float symbol + complex nil signed-byte t + cons null simple-array unsigned-byte + double-float number simple-bit-vector vector (OBJECT {var}*) (FTYPE type {function-name}*) (FUNCTION function-name ({arg-type}*) {return-type}*) @@ -1084,9 +1084,9 @@ Gives declarations. Possible DECL-SPECs are: (docfun decode-float function (float) " Returns the significand F, the exponent E, and the sign S of FLOAT. These values satisfy - 1/B <= F < 1 -and E - FLOAT = S * F * B + 1/B <= F < 1 +and E + FLOAT = S * F * B where B is the radix used to represent FLOAT. S and F are floats of the same float format as FLOAT, and E is an integer.") @@ -1094,12 +1094,12 @@ float format as FLOAT, and E is an integer.") "Syntax: (defun name lambda-list {decl | doc}* {form}*) Defines a global function named by NAME. The complete syntax of a lambda-list is: - ({var}* - [&optional {var | (var [init [svar]])}*] - [&rest var] - [&key {var | ({var | (keyword var)} [init [svar]])}* - [&allow-other-keys]] - [&aux {var | (var [init])}*]) + ({var}* + [&optional {var | (var [init [svar]])}*] + [&rest var] + [&key {var | ({var | (keyword var)} [init [svar]])}* + [&allow-other-keys]] + [&aux {var | (var [init])}*]) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function).") @@ -1107,16 +1107,16 @@ retrieved by (documentation 'NAME 'function).") "Syntax: (defmacro name defmacro-lambda-list {decl | doc}* {form}*) Defines a global macro named by NAME. The complete syntax of DEFMACRO-LAMBDA- LIST is: - ( [&whole var] [&environment var] . pvar ) + ( [&whole var] [&environment var] . pvar ) where PVAR may be a symbol, - ( {pvar}* [&optional {var | (pvar [init [pvar]])}*] . var ) + ( {pvar}* [&optional {var | (pvar [init [pvar]])}*] . var ) or - ( {pvar}* - [&optional {var | (pvar [init [pvar]])}*] - [{&rest | &body} pvar] - [&key {var | ({var | (keyword pvar)} [init [pvar]])}* - [&allow-other-keys]] - [&aux {var | (pvar [init])}*] ) + ( {pvar}* + [&optional {var | (pvar [init [pvar]])}*] + [{&rest | &body} pvar] + [&key {var | ({var | (keyword pvar)} [init [pvar]])}* + [&allow-other-keys]] + [&aux {var | (pvar [init])}*] ) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). See LIST for the backquote macro useful for defining macros.") @@ -1166,7 +1166,7 @@ ECL specific. Returns T if the ARRAY is displaced to another array; NIL otherwise.") (docfun do macro (bindings (test &optional result) &body forms) - "Syntax: (do ({(var [init [step]])}*) (test {result}*) + "Syntax: (do ({(var [init [step]])}*) (test {result}*) {decl}* {tag | statement}*) Establishes a NIL block, binds each VAR to the value of the corresponding INIT @@ -1178,14 +1178,14 @@ values of the last RESULT. Performs variable bindings and assignments in parallel, just as LET and PSETQ do.") (docfun do* macro (bindings (test &optional result) &body forms) - "Syntax: (do* ({(var [init [step]])}*) (test {result}*) + "Syntax: (do* ({(var [init [step]])}*) (test {result}*) {decl}* {tag | statement}*) Similar to DO, but performs variable bindings and assignments in serial, just as LET* and SETQ do.") (docfun dolist macro ((var form &optional result) &body forms) - "Establishes a NIL block and executes STATEMENTs once for each member of the + "Establishes a NIL block and executes STATEMENTs once for each member of the list value of FORM, with VAR bound to the member. Then evaluates RESULT (which defaults to NIL) and returns all values.") @@ -1194,7 +1194,7 @@ A double-float is a double-precision floating point number. DOUBLE-FLOAT as a type specifier is equivalent to LONG-FLOAT in ECL.") (docfun dotimes macro ((var form &optional result) &body forms) - "Establishes a NIL block and executes STATEMENTs once for each integer between + "Establishes a NIL block and executes STATEMENTs once for each integer between 0 (inclusive) and the value of FORM (exclusive), with VAR bound to the integer. Then evaluates RESULT (which defaults to NIL) and returns all values.") @@ -1219,27 +1219,27 @@ Returns T if the args are identical; NIL otherwise.") (docfun eql function (x y) " Returns T if the args satisfy one of the following conditions. - 1. identical - 2. are numbers of the same type with the same value - 3. are characters that represent the same character + 1. identical + 2. are numbers of the same type with the same value + 3. are characters that represent the same character Returns NIL otherwise.") (docfun equal function (x y) " Returns T if the args satisfy one of the following conditions. - 1. EQL - 2. are conses with EQUAL cars and EQUAL cdrs - 3. are strings of the same length and element-wise EQL - 4. are bit-vectors of the same length and element-wise EQL - 5. are pathnames with EQUAL slots + 1. EQL + 2. are conses with EQUAL cars and EQUAL cdrs + 3. are strings of the same length and element-wise EQL + 4. are bit-vectors of the same length and element-wise EQL + 5. are pathnames with EQUAL slots Returns NIL otherwise.") (docfun equalp function (x y) " Returns T if the args satisfy one of the following conditions. - 1. EQUAL - 2. are characters that satisfy CHARACTER-EQUAL - 3. are numbers that satisfy = - 4. are conses with EQUALP cars and EQUALP cdrs - 5. are arrays of the same dimensions and element-wise EQUALP + 1. EQUAL + 2. are characters that satisfy CHARACTER-EQUAL + 3. are numbers that satisfy = + 4. are conses with EQUALP cars and EQUALP cdrs + 5. are arrays of the same dimensions and element-wise EQUALP Returns NIL otherwise.") (docfun error function (format-string &rest args) " @@ -1251,9 +1251,9 @@ Evaluates FORM and returns all values.") (docfun eval-when special ((&rest situation) &body forms) " Specifies when to evaluate FORMs. Each SITUATION must be one of the following symbols. - COMPILE (compile-time) - LOAD (load-time of the fasl file) - EVAL (load-time of the source file)") + COMPILE (compile-time) + LOAD (load-time of the fasl file) + EVAL (load-time of the source file)") (docfun evalhook function (form fun1 fun2 &optional (env nil)) " Evaluates FORM with *EVALHOOK* bound to FUN1 and *APPLYHOOK* bound to FUN2, @@ -1336,9 +1336,9 @@ such package exists. NAME may be a string or a symbol.") Searches PACKAGE for a symbol whose print name is NAME. If such a symbol is found, then returns the symbol as the first value and returns one of the following symbols as the second value. - :INTERNAL (internal symbol in PACKAGE) - :EXTERNAL (external symbol in PACKAGE) - :INHERITED (external symbol of a package that PACKAGE is using) + :INTERNAL (internal symbol in PACKAGE) + :EXTERNAL (external symbol in PACKAGE) + :INHERITED (external symbol of a package that PACKAGE is using) If no such symbol is found, returns NIL as the first and second values.") (docfun finish-output function (&optional (stream *standard-output*)) " @@ -1365,16 +1365,16 @@ other format is called SINGLE-FLOAT, DOUBLE-FLOAT, or LONG-FLOAT. Precisions and exponent sizes of floats depends on the version of ECL. See the ECL Report at your hand for details. The following syntax is used to notate a float. - [+ | -] {digit}* . {digit}+ [exp] - [+ | -] {digit}+ [. {digit}*}] exp + [+ | -] {digit}* . {digit}+ [exp] + [+ | -] {digit}+ [. {digit}*}] exp where DIGIT is a decimal digit (0,..,9) and EXP is - marker [+ | -] {digit}+ + marker [+ | -] {digit}+ with one of the following marker. - e or E the default float format - s or S short-float - f or F single-float - d or D double-float - l or L long-float + e or E the default float format + s or S short-float + f or F single-float + d or D double-float + l or L long-float The default float format is single-float normally, but may be any other float format. See *READ-DEFAULT-FLOAT-FORMAT*.") @@ -1418,16 +1418,16 @@ STRING is a string consisting of characters to output and format directives which begin with '~~'. Outputs to DESTINATION if it is a stream and to the standard output if DESTINATION is T. If DESTINATION is NIL, does not output actually but returns the output as a string. Here are some format directives: - ~~A PRINCs one arg - ~~S PRIN1s one arg - ~~D Prints one integer in decimal - ~~B Prints one integer in binary - ~~O Prints one integer in octal - ~~X Prints one integer in hexa - ~~% Does TERPRI - ~~& Does FRESH-LINE - ~~| Outputs #\\Page - ~~~~ Outputs '~~'") + ~~A PRINCs one arg + ~~S PRIN1s one arg + ~~D Prints one integer in decimal + ~~B Prints one integer in binary + ~~O Prints one integer in octal + ~~X Prints one integer in hexa + ~~% Does TERPRI + ~~& Does FRESH-LINE + ~~| Outputs #\\Page + ~~~~ Outputs '~~'") (docfun fourth function (x) " Equivalent to CADDDR.") @@ -1452,17 +1452,17 @@ call returns.") (doctype function " A function object specifies a function to be invoked by function-calling functions such as FUNCALL or APPLY. A function is either: - 1. a compiled function - 2. a list of one of the following form - (lambda lambda-list . body) - (lambda-block block-name lambda-list . body) - (lambda-closure env1 env2 env3 lambda-list . body) - (lambda-block-closure env1 env2 env3 block-name lambda-list - . body) - where ENV1, ENV2, and ENV3 respectively represent the variable - environment, the function/macro environment, and the block/tagbody - environment at the time of the function creation. - 3. a symbol that names a global function.") + 1. a compiled function + 2. a list of one of the following form + (lambda lambda-list . body) + (lambda-block block-name lambda-list . body) + (lambda-closure env1 env2 env3 lambda-list . body) + (lambda-block-closure env1 env2 env3 block-name lambda-list + . body) + where ENV1, ENV2, and ENV3 respectively represent the variable + environment, the function/macro environment, and the block/tagbody + environment at the time of the function creation. + 3. a symbol that names a global function.") (docfun function special (function-name) " If X is a lambda expression, (function x) creates and returns a lexical closure @@ -1544,7 +1544,7 @@ specified environment is not found.") Searches PLIST for a property that is EQ to PROPERTY. If one is found, returns the value of the property. If not, returns DEFAULT. The SETF form - (setf (getf place property-form) value-form) + (setf (getf place property-form) value-form) replaces the property value of the plist stored in PLACE, or adds a new property if the plist does not have the property yet.") @@ -1614,7 +1614,7 @@ than #\\Newline. Returns NIL otherwise.") (doctype hash-table " A hash-table is a table used to map from objects to objects efficiently by the hashing technique. A hash-table is notated as - # + # where N is actually a number that identifies the hash-table.") (docfun hash-table-count function (hash-table) " @@ -1691,24 +1691,24 @@ Equivalent to CODE-CHAR.") An integer object represents an integer in mathematical sense. An integer may be a fixnum, or else it is a bignum. Normally, an integer is notated in radix 10 (see *PRINT-BASE* and *READ-BASE*) as - [sign] {digit}+ + [sign] {digit}+ where DIGIT is a decimal digit ('0', ..., '9') and SIGN is either '+' or '-'. Also, the following syntax is used to notate the radix explicitly. - # radix {r | R} [sign] {digit}+ + # radix {r | R} [sign] {digit}+ where RADIX is one of '2', '3', ..., '36' and DIGIT is a digit in radix RADIX: - Digits in radix 2 are '0' and '1' - Digits in radix 8 are '0', ..., '7' - Digits in radix 16 are '0', ..., '9', 'a', ..., 'f', and 'A', ..., 'F' + Digits in radix 2 are '0' and '1' + Digits in radix 8 are '0', ..., '7' + Digits in radix 16 are '0', ..., '9', 'a', ..., 'f', and 'A', ..., 'F' The following syntax is also available for radix 2, 8, 10, and 16. - # {b | B} [sign] {digit}+ - # {o | O} [sign] {digit}+ - [sign] {digit}+ . - # {x | X} [sign] {digit}+") + # {b | B} [sign] {digit}+ + # {o | O} [sign] {digit}+ + [sign] {digit}+ . + # {x | X} [sign] {digit}+") (docfun integer-decode-float function (float) " Returns, as three values, the integer interpretation of significand F, the exponent E, and the sign S of FLOAT, such that - FLOAT = S * F * B^E + FLOAT = S * F * B^E where B = (float-radix FLOAT). F is a non-negative integer, E is an integer, and S is either 1 or -1.") @@ -1745,9 +1745,9 @@ simply ignored.") (docvar lambda-list-keywords constant " List of all lambda-list keywords, including - &optional &rest &key - &allow-other-keys &aux - &whole &environment &body") + &optional &rest &key + &allow-other-keys &aux + &whole &environment &body") (docvar lambda-parameters-limit constant " The upper bound of the number of parameters specified by a lambda list. @@ -1918,7 +1918,7 @@ simply ignored.") (docfun make-broadcast-stream function (&rest streams) " Creates and returns a broadcast stream. Outputs to this stream are output to all STREAMs. A broadcast stream is notated as - # + # where N is a number that identify the stream.") (docfun make-char function (char &optional (bits 0) (font 0)) " @@ -1930,7 +1930,7 @@ Creates and returns a concatenated stream. Inputs from this stream are first obtained from the first STREAM. When the end of the first STREAM is reached, then inputs are obtained from the second STREAM. And so forth. A concatenated stream is notated as - # + # where N is a number that identifies the stream.") (docfun make-dispatch-macro-character function (char &optional (non-terminating-p nil) (readtable *readtable*)) " @@ -1942,7 +1942,7 @@ Creates and returns an echo stream. Inputs from this stream are obtained from STREAM1 and outputs to this stream are output to STREAM2. In addition, all inputs from STREAM1 are output to STREAM2. An echo stream is notated as - # + # where N is a number that identifies the stream.") (docfun make-hash-table function (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7)) " @@ -1991,14 +1991,14 @@ INITIAL-ELEMENT.") (docfun make-string-input-stream function (string &optional (start 0) (end (length string))) " Creates and returns a string-input stream. Inputs from this stream are obtained form STRING. A string-input stream is notated as - # + # where S is a string.") (docfun make-string-output-stream function () " Creates and returns a string-output stream. Outputs to this stream are obtained as a string by GET-OUTPUT-STREAM-STRING. A string-output stream is notated as - # + # where N is a number that identifies the stream.") (docfun si::make-string-output-stream-from-string function (string) " @@ -2013,14 +2013,14 @@ Creates and returns a new uninterned symbol whose print name is STRING.") Creates and returns a synonym stream to SYMBOL. Inputs from this stream are obtained from, and outputs to this stream are sent to the stream that is the value of the global variable named SYMBOL. A synonym stream is notated as - # + # where S is a symbol.") (docfun make-two-way-stream function (stream1 stream2) " Creates and returns a two-way stream. Inputs from this stream are obtained from STREAM1 and outputs to this stream are sent to STREAM2. A two-way stream is notated as - # + # where N is a number that identifies the stream.") (docfun makunbound function (symbol) " @@ -2092,7 +2092,7 @@ Returns T if NUMBER is negative; NIL otherwise.") (docfun mod function (number divisor) " Returns the second result of (FLOOR NUMBER DIVISOR), i.e. the value of - (- NUMBER (* (FLOOR NUMBER DIVISOR) DIVISOR))") + (- NUMBER (* (FLOOR NUMBER DIVISOR) DIVISOR))") (docvar most-negative-double-float constant " Same as MOST-NEGATIVE-LONG-FLOAT.") @@ -2242,10 +2242,10 @@ DOES-NOT-EXIST specifies what to do when the specified file does not exists. It may be :ERROR (the default when DIRECTION is :INPUT), :CREATE (the default when DIRECTION is either :OUTPUT or :IO), or NIL. File streams are notated in one of the following ways: - # - # - # - # + # + # + # + # where F is the file name.") (docfun ext:make-pipe function () @@ -2264,11 +2264,11 @@ Returns T if STREAM can handle output operations; NIL otherwise.") A package object serves as a name space of symbols. A package is notated as # where S is actually the name of the package. ECL provides five built-in packages: - lisp standard symbols of Common Lisp. - user the package that the user uses by default. - keyword keyword symbols. - system system internal symbols. Has nicknames SYS and SI. - compiler system internal symbols for the ECL compiler.") + lisp standard symbols of Common Lisp. + user the package that the user uses by default. + keyword keyword symbols. + system system internal symbols. Has nicknames SYS and SI. + compiler system internal symbols for the ECL compiler.") (docfun package-name function (package) " Returns the name of PACKAGE as a string.") @@ -2386,11 +2386,11 @@ Returns NIL if no such element exists.") (docfun pprint function (object &optional (stream *standard-output*)) " Pretty-prints OBJECT. Returns no values. Equivalent to - (PROGN (WRITE OBJECT :STREAM STREAM :PRETTY T :ESCAPE T) - (VALUES)) + (PROGN (WRITE OBJECT :STREAM STREAM :PRETTY T :ESCAPE T) + (VALUES)) The SI::PRETTY-PRINT-FORMAT property N (which must be a non-negative integer) of a symbol SYMBOL controls the pretty-printing of form - (SYMBOL f1 ... fN fN+1 ... fM) + (SYMBOL f1 ... fN fN+1 ... fM) in such a way that the subforms fN+1, ..., fM are regarded as the 'body' of the entire form. For instance, the property value of 2 is initially given to the symbol DO.") @@ -2406,8 +2406,8 @@ Prints OBJECT without escape characters. Returns OBJECT. Equivalent to (docfun print function (object &optional (stream *standard-output*)) " Outputs a newline character, and then PRIN1s OBJECT. Returns OBJECT. Equivalent to - (PROGN (TERPRI STREAM) - (WRITE OBJECT :STREAM STREAM :ESCAPE T))") + (PROGN (TERPRI STREAM) + (WRITE OBJECT :STREAM STREAM :ESCAPE T))") (docfun probe-file function (filespec) " Returns the full pathname of the specified file if it exists. Returns NIL @@ -2448,18 +2448,18 @@ The function KEY is applied to extract the key for comparison.") (doctype ratio " A ratio is notated by its numerator and denominator, separated by a slash '/'. Normally, a ratio is notated in radix 10 (see *PRINT-BASE* and *READ-BASE*) as - [sign] {digit}+ / {digit}+ + [sign] {digit}+ / {digit}+ where DIGIT is a decimal digit ('0', ..., '9') and SIGN is either '+' or '-'. Also, the following syntax is used to notate the radix explicitly. - # radix {r | R} [sign] {digit}+ / {digit}+ + # radix {r | R} [sign] {digit}+ / {digit}+ where RADIX is one of '2', '3', ..., '36' and DIGIT is a digit in radix RADIX: - Digits in radix 2 are '0' and '1' - Digits in radix 8 are '0', ..., '7' - Digits in radix 16 are '0', ..., '9', 'a', ..., 'f', and 'A', ..., 'F' + Digits in radix 2 are '0' and '1' + Digits in radix 8 are '0', ..., '7' + Digits in radix 16 are '0', ..., '9', 'a', ..., 'f', and 'A', ..., 'F' The following syntax is also available for radix 2, 8, 10, and 16. - # {b | B} [sign] {digit}+ / {digit}+ - # {o | O} [sign] {digit}+ / {digit}+ - # {x | X} [sign] {digit}+ / {digit}+") + # {b | B} [sign] {digit}+ / {digit}+ + # {o | O} [sign] {digit}+ / {digit}+ + # {x | X} [sign] {digit}+ / {digit}+") (docfun rational function (real) " Converts REAL into rational accurately and returns the result.") @@ -2508,16 +2508,16 @@ Each readtable object remembers the syntactic class of each character. The following syntactic classes are supported. The characters in parenthesis below are those standard characters that belong to each syntactic class as defined in the standard readtable. - white-space (space and newline) - single-escape ( \\ ) - multiple-escape ( | ) - macro-character ( \" # ' ( ) , ; ` ) - constituent (the others) + white-space (space and newline) + single-escape ( \\ ) + multiple-escape ( | ) + macro-character ( \" # ' ( ) , ; ` ) + constituent (the others) For each macro-character, the readtable remembers the definition of the associated read macro and the non-terminating-p flag. In the standard readtable, only single-quote is non-terminating. Dispatch macro characters are classified to macro-characters. A readtable is notated as - # + # where N is actually a number that identifies the readtable.") (docfun readtablep function (x) " @@ -2532,7 +2532,7 @@ Combines all the elements of SEQUENCE using the binary operation FUNCTION.") (docfun rem function (number divisor) " Returns the second value of (TRUNCATE NUMBER DIVISOR), i.e. the value of - (- NUMBER (* (TRUNCATE NUMBER DIVISOR) DIVISOR))") + (- NUMBER (* (TRUNCATE NUMBER DIVISOR) DIVISOR))") (docfun remhash function (key hash-table) " Removes the entry for KEY in HASH-TABLE. Returns T if such an entry existed; @@ -2749,27 +2749,27 @@ Removes the value associated with the INDEX-th slot of INSTANCE.") (docfun special-operator-p function (symbol) " Returns T if SYMBOL names a special form; NIL otherwise. The special forms defined in Common Lisp are: - block if progv - catch labels quote - compiler-let let return-from - declare let* setq - eval-when macrolet tagbody - flet multiple-value-call the - function multiple-value-prog1 throw - go progn unwind-protect + block if progv + catch labels quote + compiler-let let return-from + declare let* setq + eval-when macrolet tagbody + flet multiple-value-call the + function multiple-value-prog1 throw + go progn unwind-protect In addition, ECL implements the following macros as special forms, though of course macro-expanding functions such as MACROEXPAND work correctly for these macros. - and incf prog1 - case locally prog2 - cond loop psetq - decf multiple-value-bind push - defmacro multiple-value-list return - defun multiple-value-set setf - do or unless - do* pop when - dolist prog - dotimes prog*") + and incf prog1 + case locally prog2 + cond loop psetq + decf multiple-value-bind push + defmacro multiple-value-list return + defun multiple-value-set setf + do or unless + do* pop when + dolist prog + dotimes prog*") (docfun si::specialp function (symbol) " ECL specific. @@ -2781,11 +2781,11 @@ Returns the square root of the arg.") (doctype standard-char " A standard-char is a space character (#\\Space), a newline character (#\\Newline,) or a character that represents one of the following letters. - ! \" # $ % & ' ( ) * + , - . / 0 1 2 3 4 - 5 6 7 8 9 : ; < = > ? @ A B C D E F G H - I J K L M N O P Q R S T U V W X Y Z [ \\ - ] ^ _ ` a b c d e f g h i j k l m n o p - q r s t u v w x y z { | } ~~") + ! \" # $ % & ' ( ) * + , - . / 0 1 2 3 4 + 5 6 7 8 9 : ; < = > ? @ A B C D E F G H + I J K L M N O P Q R S T U V W X Y Z [ \\ + ] ^ _ ` a b c d e f g h i j k l m n o p + q r s t u v w x y z { | } ~~") (docfun standard-char-p function (char) " Returns T if CHAR is a standard-char; NIL otherwise.") @@ -2793,14 +2793,14 @@ Returns T if CHAR is a standard-char; NIL otherwise.") (doctype stream " A stream is a source of input or a destination of output. The following kinds of streams are supported. - file streams - string-input streams - string-output streams - two-way streams - echo streams - synonym streams - concatenated streams - broadcast streams + file streams + string-input streams + string-output streams + two-way streams + echo streams + synonym streams + concatenated streams + broadcast streams Basically, file streams are created by OPEN and other kinds of streams are created by MAKE-...-STREAM. See these functions.") @@ -3230,12 +3230,12 @@ to be performed to build the system will be printed. ") (docfun sbt::defsystem macro - "(name &key :modules :directory :pathname-types)" " + "(name &key :modules :directory :pathname-types)" " NAME should be a symbol which will be used to refer to the system. The value of :MODULES should be a list of module dependencies of the form: - (file load-deps compile-deps recompilation-deps) + (file load-deps compile-deps recompilation-deps) where load-deps compile-deps recompilation-deps are lists of module names. If the value specified for :directory is a cons, then the CAR is used as diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 203ccdfdd..9bb4c13d9 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -2,9 +2,9 @@ /********************************************************************** *** *** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY - *** APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER - *** IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER - *** CODE. + *** APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER + *** IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER + *** CODE. **********************************************************************/ /* * See ecl/src/c/interpreter.d for a detailed explanation of all opcodes @@ -110,7 +110,7 @@ typedef int16_t cl_oparg; # define OPCODE_SIZE 1 # define OPARG_SIZE 2 # ifdef WORDS_BIGENDIAN -# define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] +# define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] # else # define READ_OPARG(v) ((cl_fixnum)v[1] << 8) + (unsigned char)v[0] # endif @@ -119,24 +119,24 @@ typedef int16_t cl_oparg; typedef int16_t cl_opcode; # define OPCODE_SIZE 1 # define OPARG_SIZE 1 -# define READ_OPCODE(v) v[0] -# define READ_OPARG(v) v[0] +# define READ_OPCODE(v) v[0] +# define READ_OPARG(v) v[0] # define GET_OPARG(r,v) { r = *(v++); } #endif #define GET_OPCODE(v) *((v)++) #define GET_DATA(r,v,data) { \ - cl_oparg ndx; \ - GET_OPARG(ndx, v); \ - r = data[ndx]; \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data[ndx]; \ } #define GET_DATA_PTR(r,v,data) { \ - cl_oparg ndx; \ - GET_OPARG(ndx, v); \ - r = data+ndx; \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data+ndx; \ } -#define GET_LABEL(pc,v) { \ - pc = (v) + READ_OPARG(v); \ - v += OPARG_SIZE; \ +#define GET_LABEL(pc,v) { \ + pc = (v) + READ_OPARG(v); \ + v += OPARG_SIZE; \ } /********************************************************************** @@ -160,25 +160,25 @@ typedef int16_t cl_oparg; #ifdef ECL_THREADED_INTERPRETER #define BEGIN_SWITCH \ - THREAD_NEXT; + THREAD_NEXT; #define CASE(name) \ - LBL_##name: + LBL_##name: #define THREAD_NEXT \ - goto *(&&LBL_OP_NOP + offsets[GET_OPCODE(vector)]) + goto *(&&LBL_OP_NOP + offsets[GET_OPCODE(vector)]) #else #define BEGIN_SWITCH \ - switch (GET_OPCODE(vector)) + switch (GET_OPCODE(vector)) #define THREAD_NEXT \ - goto BEGIN + goto BEGIN #define CASE(name) \ - case name: + case name: #endif #if !defined(ECL_THREADED_INTERPRETER) #define ECL_OFFSET_TABLE #else #define ECL_OFFSET_TABLE \ - static const int offsets[] = {\ + static const int offsets[] = {\ &&LBL_OP_NOP - &&LBL_OP_NOP,\ &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ &&LBL_OP_ENDP - &&LBL_OP_NOP,\ diff --git a/src/h/cache.h b/src/h/cache.h index 473dd1813..714bea155 100644 --- a/src/h/cache.h +++ b/src/h/cache.h @@ -21,18 +21,18 @@ extern "C" { #endif typedef struct ecl_cache { - cl_object keys; - cl_object table; - cl_index generation; + cl_object keys; + cl_object table; + cl_index generation; #ifdef ECL_THREADS - cl_object clear_list; + cl_object clear_list; #endif } *ecl_cache_ptr; typedef struct ecl_cache_record { - cl_object key; /* vector[ndx] */ - cl_object value; /* vector[ndx+1] */ - cl_object gen; /* vector[ndx+2] */ + cl_object key; /* vector[ndx] */ + cl_object value; /* vector[ndx+1] */ + cl_object gen; /* vector[ndx+2] */ } *ecl_cache_record_ptr; extern ecl_cache_ptr ecl_make_cache(cl_index key_size, cl_index cache_size); diff --git a/src/h/config.h.in b/src/h/config.h.in index 169049e54..697d62379 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -49,7 +49,7 @@ /* * FEATURES LINKED IN */ -/* Always use CLOS */ +/* Always use CLOS */ #define CLOS /* Use GNU Multiple Precision library for bignums */ @@ -57,7 +57,7 @@ #include "@ECL_GMP_HEADER@" #endif -/* Userland threads? */ +/* Userland threads? */ #undef ECL_THREADS #ifdef ECL_THREADS # if defined(ECL_MS_WINDOWS_HOST) @@ -72,11 +72,11 @@ #undef WITH___THREAD #endif -/* Use Boehm's garbage collector */ +/* Use Boehm's garbage collector */ #undef GBC_BOEHM #ifdef GBC_BOEHM # ifdef ECL_THREADS -# define GC_THREADS /* For >= 7.2 */ +# define GC_THREADS /* For >= 7.2 */ # endif # define ECL_DYNAMIC_VV # include "@ECL_BOEHM_GC_HEADER@" @@ -91,30 +91,30 @@ #endif #undef ECL_LIBATOMIC_OPS_H -/* Network streams */ +/* Network streams */ #undef TCP #if defined(TCP) && defined(ECL_MS_WINDOWS_HOST) # define ECL_WSOCK #endif -/* Foreign functions interface */ +/* Foreign functions interface */ #undef ECL_FFI /* Support for Unicode strings */ #undef ECL_UNICODE -/* Link in the Unicode names for all characters (takes ~0.5 Mb) */ +/* Link in the Unicode names for all characters (takes ~0.5 Mb) */ #undef ECL_UNICODE_NAMES -/* Allow STREAM operations to work on arbitrary objects */ +/* Allow STREAM operations to work on arbitrary objects */ #undef ECL_CLOS_STREAMS -/* Stack grows downwards */ +/* Stack grows downwards */ #undef ECL_DOWN_STACK /* We have libffi and can use it */ #undef HAVE_LIBFFI -/* We have non-portable implementation of FFI calls */ +/* We have non-portable implementation of FFI calls */ /* Only used as a last resort, when libffi is missin */ #ifndef HAVE_LIBFFI #undef ECL_DYNAMIC_FFI @@ -123,13 +123,13 @@ /* We use hierarchical package names, like in Allegro CL */ #undef ECL_RELATIVE_PACKAGE_NAMES -/* Use mprotect for fast interrupt dispatch */ +/* Use mprotect for fast interrupt dispatch */ #undef ECL_USE_MPROTECT #if defined(ECL_MS_WINDOWS_HOST) # define ECL_USE_GUARD_PAGE #endif -/* Integer types */ +/* Integer types */ @ECL_STDINT_HEADER@ #undef ecl_uint8_t #undef ecl_int8_t @@ -153,11 +153,11 @@ * but the required headers are not present in all systems. Hence we * use autoconf to guess the following values. */ -#define ECL_INT_BITS @CL_INT_BITS@ -#define ECL_LONG_BITS @CL_LONG_BITS@ -#define FIXNUM_BITS @CL_FIXNUM_BITS@ -#define MOST_POSITIVE_FIXNUM ((cl_fixnum)@CL_FIXNUM_MAX@) -#define MOST_NEGATIVE_FIXNUM ((cl_fixnum)@CL_FIXNUM_MIN@) +#define ECL_INT_BITS @CL_INT_BITS@ +#define ECL_LONG_BITS @CL_LONG_BITS@ +#define FIXNUM_BITS @CL_FIXNUM_BITS@ +#define MOST_POSITIVE_FIXNUM ((cl_fixnum)@CL_FIXNUM_MAX@) +#define MOST_NEGATIVE_FIXNUM ((cl_fixnum)@CL_FIXNUM_MIN@) #define MOST_POSITIVE_FIXNUM_VAL @CL_FIXNUM_MAX@ #define MOST_NEGATIVE_FIXNUM_VAL @CL_FIXNUM_MIN@ @@ -168,20 +168,20 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; /* * The character type */ -#define ECL_CHAR_CODE_LIMIT @CHAR_CODE_LIMIT@ /* ASCII or unicode character code limit */ +#define ECL_CHAR_CODE_LIMIT @CHAR_CODE_LIMIT@ /* ASCII or unicode character code limit */ typedef @ECL_CHARACTER@ ecl_character; typedef unsigned char ecl_base_char; /* * Array limits */ -#define ECL_ARRAY_RANK_LIMIT 64 /* array rank limit */ +#define ECL_ARRAY_RANK_LIMIT 64 /* array rank limit */ #ifdef GBC_BOEHM -#define ECL_ARRAY_DIMENSION_LIMIT @CL_FIXNUM_MAX@ -#define ECL_ARRAY_TOTAL_LIMIT @CL_FIXNUM_MAX@ +#define ECL_ARRAY_DIMENSION_LIMIT @CL_FIXNUM_MAX@ +#define ECL_ARRAY_TOTAL_LIMIT @CL_FIXNUM_MAX@ #else -#define ECL_ARRAY_DIMENSION_LIMIT 16*1024*1024 -#define ECL_ARRAY_TOTAL_LIMIT 16*1024*1024 +#define ECL_ARRAY_DIMENSION_LIMIT 16*1024*1024 +#define ECL_ARRAY_TOTAL_LIMIT 16*1024*1024 #endif /* @@ -189,22 +189,22 @@ typedef unsigned char ecl_base_char; * * In general, any of these limits must fit in a "signed int". */ -/* Maximum number of function arguments (arbitrary) */ +/* Maximum number of function arguments (arbitrary) */ #define ECL_CALL_ARGUMENTS_LIMIT 65536 -/* Maximum number of required arguments */ +/* Maximum number of required arguments */ #define ECL_LAMBDA_PARAMETERS_LIMIT ECL_CALL_ARGUMENTS_LIMIT -/* Numb. of args. which will be passed using the C stack */ -/* See cmplam.lsp if you change this value */ +/* Numb. of args. which will be passed using the C stack */ +/* See cmplam.lsp if you change this value */ #define ECL_C_ARGUMENTS_LIMIT 63 -/* Maximum number of output arguments (>= ECL_C_ARGUMENTS_LIMIT) */ +/* Maximum number of output arguments (>= ECL_C_ARGUMENTS_LIMIT) */ #define ECL_MULTIPLE_VALUES_LIMIT 64 -/* A setjmp that does not save signals */ -#define ecl_setjmp @ECL_SETJMP@ -#define ecl_longjmp @ECL_LONGJMP@ +/* A setjmp that does not save signals */ +#define ecl_setjmp @ECL_SETJMP@ +#define ecl_longjmp @ECL_LONGJMP@ /* * Structure/Instance limits. The index to a slot must fit in the @@ -212,7 +212,7 @@ typedef unsigned char ecl_base_char; * because constructors typically require as many arguments as slots, * or more. */ -#define ECL_SLOTS_LIMIT 32768 +#define ECL_SLOTS_LIMIT 32768 /* compiler understands long double */ #undef ECL_LONG_FLOAT @@ -220,10 +220,10 @@ typedef unsigned char ecl_base_char; #undef HAVE_DOUBLE_COMPLEX #undef HAVE_FLOAT_COMPLEX -/* We can use small, two-words conses, without type information */ +/* We can use small, two-words conses, without type information */ #undef ECL_SMALL_CONS -/* Use CMU Common-Lisp's FORMAT routine */ +/* Use CMU Common-Lisp's FORMAT routine */ #undef ECL_CMU_FORMAT /* @@ -263,105 +263,105 @@ typedef unsigned char ecl_base_char; #undef ECL_SSE2 #endif -/* -CUT-: Everything below this mark will not be installed */ +/* -CUT-: Everything below this mark will not be installed */ /* -------------------------------------------------------------------- * - * BUILD OPTIONS WHICH NEED NOT BE EXPORTED * + * BUILD OPTIONS WHICH NEED NOT BE EXPORTED * * -------------------------------------------------------------------- */ /* * FEATURES LINKED IN: */ -/* CLX */ +/* CLX */ #undef CLX -/* Locatives */ +/* Locatives */ #undef LOCATIVE -/* Use old MIT LOOP macro system */ +/* Use old MIT LOOP macro system */ #undef ECL_OLD_LOOP -/* Define this if you want a runtime version only without compiler */ +/* Define this if you want a runtime version only without compiler */ #undef RUNTIME -/* Profile tool */ +/* Profile tool */ #undef PROFILE -/* Program Development Environment */ +/* Program Development Environment */ #undef PDE -/* Allow loading dynamically linked code */ +/* Allow loading dynamically linked code */ #undef ENABLE_DLOPEN -/* Undefine this if you do not want ECL to check for circular lists */ +/* Undefine this if you do not want ECL to check for circular lists */ #define ECL_SAFE -/* Bytecodes and arguments are 8 and 16 bits large, respectively */ +/* Bytecodes and arguments are 8 and 16 bits large, respectively */ #undef ECL_SMALL_BYTECODES -/* Assembler implementation of APPLY and friends */ +/* Assembler implementation of APPLY and friends */ #undef ECL_ASM_APPLY -/* Activate Boehm-Weiser incremental garbage collector */ +/* Activate Boehm-Weiser incremental garbage collector */ #undef GBC_BOEHM_GENGC -/* Activate Boehm-Weiser precise garbage collector */ +/* Activate Boehm-Weiser precise garbage collector */ #undef GBC_BOEHM_PRECISE -/* Weak hash tables need the garbage collector and weak pointers */ +/* Weak hash tables need the garbage collector and weak pointers */ #ifdef GBC_BOEHM #define ECL_WEAK_HASH #endif -/* GC_set_start_callback */ +/* GC_set_start_callback */ #undef HAVE_GC_SET_START_CALLBACK /* * SYSTEM FEATURES: */ -/* Argument list can be access as an array */ +/* Argument list can be access as an array */ #undef ECL_USE_VARARG_AS_POINTER -/* Most significant byte first */ +/* Most significant byte first */ #undef WORDS_BIGENDIAN -/* Has */ +/* Has */ #undef HAVE_SYS_RESOURCE_H #undef HAVE_ULIMIT_H -/* High precision timer */ +/* High precision timer */ #undef HAVE_NANOSLEEP -/* Float version if isnan() */ +/* Float version if isnan() */ #undef HAVE_ISNANF -/* float.h for epsilons, maximum real numbers, etc */ +/* float.h for epsilons, maximum real numbers, etc */ #undef HAVE_FLOAT_H -/* select() */ +/* select() */ #undef HAVE_SELECT #undef HAVE_SYS_SELECT_H #undef HAVE_SYS_IOCTL_H -/* putenv() or setenv() */ +/* putenv() or setenv() */ #undef HAVE_SETENV #undef HAVE_PUTENV -/* times() and sys/times.h */ +/* times() and sys/times.h */ #undef HAVE_TIMES -/* gettimeofday() and sys/time.h */ +/* gettimeofday() and sys/time.h */ #undef HAVE_GETTIMEOFDAY -/* getrusage() and sys/resource.h */ +/* getrusage() and sys/resource.h */ #undef HAVE_GETRUSAGE -/* user home directory, user name, etc... */ +/* user home directory, user name, etc... */ #undef HAVE_PW_H -/* symbolic links and checking their existence */ +/* symbolic links and checking their existence */ #undef HAVE_LSTAT -/* safe creation of temporary files */ +/* safe creation of temporary files */ #undef HAVE_MKSTEMP -/* timer for userland threads */ +/* timer for userland threads */ #undef HAVE_ALARM -/* filesytem */ +/* filesytem */ #undef HAVE_DIRENT_H -/* dynamic linking of libraries */ +/* dynamic linking of libraries */ #undef HAVE_DLFCN_H #undef HAVE_LINK_H #undef HAVE_MACH_O_DYLD_H -/* POSIX signals */ +/* POSIX signals */ #undef HAVE_SIGPROCMASK -/* isatty() checks whether a file is connected to a */ +/* isatty() checks whether a file is connected to a */ #undef HAVE_ISATTY -/* can manipulate floating point environment */ +/* can manipulate floating point environment */ #undef HAVE_FENV_H -/* can activate individual traps in floating point environment */ +/* can activate individual traps in floating point environment */ /* this flag has to be deactivated for the Itanium architecture, where */ /* the GNU libc functions are broken */ #if !defined(__ia64__) && !defined(PPC) @@ -369,15 +369,15 @@ typedef unsigned char ecl_base_char; #endif /* do we want to deactivate all support for floating point exceptions */ #undef ECL_AVOID_FPE_H -/* do we want to have signed zeros */ +/* do we want to have signed zeros */ #undef ECL_SIGNED_ZERO -/* do we want NaNs and Infs */ +/* do we want NaNs and Infs */ #undef ECL_IEEE_FP -/* has support for large files */ +/* has support for large files */ #undef HAVE_FSEEKO -/* the tzset() function gets the current time zone */ +/* the tzset() function gets the current time zone */ #undef HAVE_TZSET -/* several floating point functions (ISO C99) */ +/* several floating point functions (ISO C99) */ #if 0 #undef HAVE_EXPF #undef HAVE_LOGF @@ -400,20 +400,20 @@ typedef unsigned char ecl_base_char; #undef HAVE_COPYSIGNF #undef HAVE_COPYSIGN #undef HAVE_COPYSIGNL -/* whether we have sched_yield() that gives priority to other threads */ +/* whether we have sched_yield() that gives priority to other threads */ #undef HAVE_SCHED_YIELD /* whether we have a working sem_init() */ #undef HAVE_SEM_INIT /* whether we have read/write locks */ #undef HAVE_POSIX_RWLOCK -/* uname() for system identification */ +/* uname() for system identification */ #undef HAVE_UNAME #undef HAVE_UNISTD_H #undef HAVE_SYS_WAIT_H #undef HAVE_SYS_MMAN_H -/* size of long long */ +/* size of long long */ #undef ECL_LONG_LONG_BITS -/* existence of char **environ */ +/* existence of char **environ */ #undef HAVE_ENVIRON /* existence of pointer -> function name functions */ #undef HAVE_DLADDR @@ -435,7 +435,7 @@ typedef unsigned char ecl_base_char; # endif #endif -/* what characters are used to mark beginning of new line */ +/* what characters are used to mark beginning of new line */ #undef ECL_NEWLINE_IS_CRLF #undef ECL_NEWLINE_IS_LFCR @@ -446,41 +446,41 @@ typedef unsigned char ecl_base_char; /* * Memory limits for the old garbage collector. */ -#define LISP_PAGESIZE 2048 /* Page size in bytes */ -#define MAXPAGE 65536 /* Maximum Memory Size */ +#define LISP_PAGESIZE 2048 /* Page size in bytes */ +#define MAXPAGE 65536 /* Maximum Memory Size */ /* We allocate a number of strings in a pool which is used to speed up reading */ -#define ECL_MAX_STRING_POOL_SIZE 10 -#define ECL_BUFFER_STRING_SIZE 4192 +#define ECL_MAX_STRING_POOL_SIZE 10 +#define ECL_BUFFER_STRING_SIZE 4192 /* * Macros that depend on these system features. */ #if defined(sparc) || defined(i386) || defined(mips) -# define stack_align(n) (((n) + 0x7) & ~0x7) +# define stack_align(n) (((n) + 0x7) & ~0x7) #else -# define stack_align(n) (((n) + 03) & ~03) +# define stack_align(n) (((n) + 03) & ~03) #endif #undef FILE_CNT #if @ECL_FILE_CNT@ == 1 -# define FILE_CNT(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) +# define FILE_CNT(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr) #endif #if @ECL_FILE_CNT@ == 2 -# define FILE_CNT(fp) ((fp)->_r) +# define FILE_CNT(fp) ((fp)->_r) #endif #if @ECL_FILE_CNT@ == 3 -# define FILE_CNT(fp) ((fp)->_cnt) +# define FILE_CNT(fp) ((fp)->_cnt) #endif #if defined(cygwin) || defined(ECL_MS_WINDOWS_HOST) # define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) -# define DIR_SEPARATOR '/' -# define PATH_SEPARATOR ';' +# define DIR_SEPARATOR '/' +# define PATH_SEPARATOR ';' #else # define IS_DIR_SEPARATOR(x) (x=='/') -# define DIR_SEPARATOR '/' -# define PATH_SEPARATOR ':' +# define DIR_SEPARATOR '/' +# define PATH_SEPARATOR ':' #endif #define ECL_ARCHITECTURE "@ARCHITECTURE@" diff --git a/src/h/cons.h b/src/h/cons.h index 37de436a1..a665a5a09 100644 --- a/src/h/cons.h +++ b/src/h/cons.h @@ -22,9 +22,9 @@ extern "C" { #endif -#define Null(x) ((x)==ECL_NIL) -#define CONS(a,d) ecl_cons((a),(d)) -#define ACONS(a,b,c) ecl_cons(ecl_cons((a),(b)),(c)) +#define Null(x) ((x)==ECL_NIL) +#define CONS(a,d) ecl_cons((a),(d)) +#define ACONS(a,b,c) ecl_cons(ecl_cons((a),(b)),(c)) /* BEGIN-GENERATED (gen-cons-h) */ diff --git a/src/h/cs.h b/src/h/cs.h index 716b909b2..5cd7ec35a 100644 --- a/src/h/cs.h +++ b/src/h/cs.h @@ -16,7 +16,7 @@ /* *---------------------------------------------------------------------- - * Low level stack manipulation macros + * Low level stack manipulation macros *---------------------------------------------------------------------- */ @@ -24,34 +24,34 @@ /* *---------------------------------------------------------------------- - * Stack of predefined size + * Stack of predefined size *---------------------------------------------------------------------- */ -#define cl_nextarg(arg) va_arg((arg),cl_object) +#define cl_nextarg(arg) va_arg((arg),cl_object) -#define CSTACK(size) register cl_object *_stack_top; \ - cl_object _stack_bot[size]; \ - _stack_top = _stack_bot /* __GNUC__ */ -#define CPUSH(val) *_stack_top++ = (val); +#define CSTACK(size) register cl_object *_stack_top; \ + cl_object _stack_bot[size]; \ + _stack_top = _stack_bot /* __GNUC__ */ +#define CPUSH(val) *_stack_top++ = (val); -#define CSTACK_BOT _stack_bot -#define CSTACK_TOP _stack_top +#define CSTACK_BOT _stack_bot +#define CSTACK_TOP _stack_top /*---------------------------------------------------------------------- */ #if defined(__i386__) && 0 /* Stack usage: - sp | lclm | - | ... | - | lcl1 | - bp | obp | + sp | lclm | + | ... | + | lcl1 | + bp | obp | | ret? | | arg1 | | ... | - osp | argn | - | ... | + osp | argn | + | ... | obp | | Caller pushes args and pops them after return. Result in ax. @@ -61,24 +61,24 @@ Caller pushes args and pops them after return. Result in ax. typedef char * caddr_t; #endif -#define GET_CURRENT_FRAME(frame) asm("movl (%%ebp),%0" : "=r" (frame)) -#define FRAME_CHAIN(frame) ((char **)frame)[0] -#define FRAME_SAVED_PC(frame) ((char **)frame)[1] +#define GET_CURRENT_FRAME(frame) asm("movl (%%ebp),%0" : "=r" (frame)) +#define FRAME_CHAIN(frame) ((char **)frame)[0] +#define FRAME_SAVED_PC(frame) ((char **)frame)[1] #define PC_INDEX 8 #if 0 -#define TRANSFER_CALL(fun) asm("leave"); goto *(fun) /* __GNUC__ */ +#define TRANSFER_CALL(fun) asm("leave"); goto *(fun) /* __GNUC__ */ #endif -#define CCALL(narg,fun) ({register cl_object eax asm("%eax"); \ - asm("push %0" :: "g" (narg)); \ - asm("call %0" :: "g" (fun) : "eax"); \ - asm("addl $4, %%esp" :: ); eax;}) +#define CCALL(narg,fun) ({register cl_object eax asm("%eax"); \ + asm("push %0" :: "g" (narg)); \ + asm("call %0" :: "g" (fun) : "eax"); \ + asm("addl $4, %%esp" :: ); eax;}) #if !defined(__linux__) && !defined(__FreeBSD__) #define ARGCALL CCALL -#define ARGSTACK(size) CSTACK(size) +#define ARGSTACK(size) CSTACK(size) #endif #endif @@ -89,15 +89,15 @@ typedef char * caddr_t; /* stack usage: - sp | | - | ... | + sp | | + | ... | | save $31 | \ return pointer | save regs | > frame offset - | locals | / + | locals | / fp | arg1 | first arg of this function - | ... | - | argn | - | ... | + | ... | + | argn | + | ... | | | */ @@ -112,9 +112,9 @@ typedef char * caddr_t; GDB uses symbol information from the function to determine FP. */ -#define ARGSTACK(size) register cl_object *_stack_top; \ - cl_object _stack_bot[size+1]; \ - _stack_top = _stack_bot /* __GNUC__ */ +#define ARGSTACK(size) register cl_object *_stack_top; \ + cl_object _stack_bot[size+1]; \ + _stack_top = _stack_bot /* __GNUC__ */ #endif @@ -134,26 +134,26 @@ typedef char * caddr_t; * Got this info from gdb (config/sparc/tm-sparc.h and sparc-tdep.c) */ -#define GET_CURRENT_FRAME(frame) asm("mov %%fp,%0" : "=r" (frame)) -#define FRAME_CHAIN(frame) ((caddr_t *)frame)[14] -#define FRAME_SAVED_PC(frame) ((caddr_t *)frame)[15] +#define GET_CURRENT_FRAME(frame) asm("mov %%fp,%0" : "=r" (frame)) +#define FRAME_CHAIN(frame) ((caddr_t *)frame)[14] +#define FRAME_SAVED_PC(frame) ((caddr_t *)frame)[15] /* GCC reserves 6 words for saving registers o0-05, but never does that */ -#define ARGSTACK(size) register volatile cl_object *_stack_top; \ - cl_object _stack_bot[size+1]; \ - _stack_top = _stack_bot-6 /* __GNUC__ */ +#define ARGSTACK(size) register volatile cl_object *_stack_top; \ + cl_object _stack_bot[size+1]; \ + _stack_top = _stack_bot-6 /* __GNUC__ */ #define ARGCALL(narg, fun) ({ register cl_object _res asm("%o0"); \ - asm("mov %0,%%o0" :: "r" (narg) : "%o0"); \ - asm("ld [%%sp+72],%%o1" ::: "%o1"); \ - asm("ld [%%sp+76],%%o2" ::: "%o2"); \ - asm("ld [%%sp+80],%%o3" ::: "%o3"); \ - asm("ld [%%sp+84],%%o4" ::: "%o4"); \ - asm("ld [%%sp+88],%%o5" ::: "%o5"); \ - asm("call %0,0" : : "r" (fun) ); \ - asm("nop"); _res;}) + asm("mov %0,%%o0" :: "r" (narg) : "%o0"); \ + asm("ld [%%sp+72],%%o1" ::: "%o1"); \ + asm("ld [%%sp+76],%%o2" ::: "%o2"); \ + asm("ld [%%sp+80],%%o3" ::: "%o3"); \ + asm("ld [%%sp+84],%%o4" ::: "%o4"); \ + asm("ld [%%sp+88],%%o5" ::: "%o5"); \ + asm("call %0,0" : : "r" (fun) ); \ + asm("nop"); _res;}) #endif @@ -161,18 +161,18 @@ typedef char * caddr_t; #if defined(vax) && 0 #define PC_INDEX 0 -#define TRANSFER(buf, addr) buf[PC_INDEX] = (int)addr+((((int *)addr)[0] >> 19) & 4)+4; \ - ecl_longjmp(buf) -#define TRANSFER_CALL(fun) REG = (cl_object)fun; \ - asm(" ashl $-19,(r11),r0"); \ - asm(" bicl2 $-5,r0"); \ - asm(" addl2 r11,r0"); \ - asm(" addl2 $4,r0"); \ - asm(" jmp (r0)") -#define CSTACK(size) register cl_object REG -#define CPUSH(val) (REG = (cl_object)(val), \ - asm(" pushl r11")) -#define CPOP (asm(" movl (sp)+,r11"), REG) +#define TRANSFER(buf, addr) buf[PC_INDEX] = (int)addr+((((int *)addr)[0] >> 19) & 4)+4; \ + ecl_longjmp(buf) +#define TRANSFER_CALL(fun) REG = (cl_object)fun; \ + asm(" ashl $-19,(r11),r0"); \ + asm(" bicl2 $-5,r0"); \ + asm(" addl2 r11,r0"); \ + asm(" addl2 $4,r0"); \ + asm(" jmp (r0)") +#define CSTACK(size) register cl_object REG +#define CPUSH(val) (REG = (cl_object)(val), \ + asm(" pushl r11")) +#define CPOP (asm(" movl (sp)+,r11"), REG) /* Reverse arguments on the stack, push narg, and then call. narg (r11), up (r9), dn (r8) @@ -180,23 +180,23 @@ typedef char * caddr_t; tmp = *dn; *dn++ = *up; *up-- = tmp; } */ -#define CCALL(narg, fun) (REG = (cl_object)(narg), \ - asm(" movl sp,r8"), \ - asm(" ashl $2,r11,r0"), \ - asm(" addl3 r0,sp,r9"), \ - asm(" subl2 $4,r9"), \ - asm("1: cmpl r8,r9"), \ - asm(" jgeq 2f"), \ - asm(" movl (r8),r7"), \ - asm(" movl (r9),(r8)+"), \ - asm(" movl r7,(r9)"), \ - asm(" subl2 $4,r9"), \ - asm(" jbr 1b"), \ - asm("2: pushl r11"), \ - asm(" addl3 $1,r11,r0"), \ - REG = (cl_object)(fun), \ - asm(" calls r0,(r11)"), \ - asm(" movl r0,r11"), (int)REG) +#define CCALL(narg, fun) (REG = (cl_object)(narg), \ + asm(" movl sp,r8"), \ + asm(" ashl $2,r11,r0"), \ + asm(" addl3 r0,sp,r9"), \ + asm(" subl2 $4,r9"), \ + asm("1: cmpl r8,r9"), \ + asm(" jgeq 2f"), \ + asm(" movl (r8),r7"), \ + asm(" movl (r9),(r8)+"), \ + asm(" movl r7,(r9)"), \ + asm(" subl2 $4,r9"), \ + asm(" jbr 1b"), \ + asm("2: pushl r11"), \ + asm(" addl3 $1,r11,r0"), \ + REG = (cl_object)(fun), \ + asm(" calls r0,(r11)"), \ + asm(" movl r0,r11"), (int)REG) #endif /*---------------------------------------------------------------------- */ diff --git a/src/h/ecl-cmp.h b/src/h/ecl-cmp.h index 06f3c6d7a..ca8588858 100755 --- a/src/h/ecl-cmp.h +++ b/src/h/ecl-cmp.h @@ -24,8 +24,8 @@ #include #define TRAMPOLINK(narg, vv, lk, cblock) \ - ecl_va_list args; ecl_va_start(args, narg, narg, 0); \ - return(_ecl_link_call(vv, (cl_objectfn *)lk, cblock, narg, args)) + ecl_va_list args; ecl_va_start(args, narg, narg, 0); \ + return(_ecl_link_call(vv, (cl_objectfn *)lk, cblock, narg, args)) enum ecl_locative_type { _ecl_object_loc = 0, @@ -35,9 +35,9 @@ enum ecl_locative_type { _ecl_float_loc, _ecl_double_loc #ifdef ECL_SSE2 - , _ecl_int_sse_pack_loc - , _ecl_float_sse_pack_loc - , _ecl_double_sse_pack_loc + , _ecl_int_sse_pack_loc + , _ecl_float_sse_pack_loc + , _ecl_double_sse_pack_loc #endif }; @@ -46,5 +46,5 @@ struct ecl_var_debug_info { uint8_t type; }; -#define _ecl_check_narg(n) \ - do { if (ecl_unlikely(narg != (n))) FEwrong_num_arguments_anonym();} while(0) +#define _ecl_check_narg(n) \ + do { if (ecl_unlikely(narg != (n))) FEwrong_num_arguments_anonym();} while(0) diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index a994ccaea..47719b141 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -98,22 +98,22 @@ (double)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_long_float(name,f,static,const) \ - static const struct ecl_long_float name ## _data = { \ - (int8_t)t_longfloat, 0, 0, 0, \ - (long double)(f) }; \ +#define ecl_def_ct_long_float(name,f,static,const) \ + static const struct ecl_long_float name ## _data = { \ + (int8_t)t_longfloat, 0, 0, 0, \ + (long double)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_ratio(name,num,den,static,const) \ - static const struct ecl_ratio name ## _data = { \ - (int8_t)t_ratio, 0, 0, 0, \ - den, num }; \ +#define ecl_def_ct_ratio(name,num,den,static,const) \ + static const struct ecl_ratio name ## _data = { \ + (int8_t)t_ratio, 0, 0, 0, \ + den, num }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_complex(name,real,imag,static,const) \ - static const struct ecl_complex name ## _data = { \ - (int8_t)t_complex, 0, 0, 0, \ - (cl_object)real, (cl_object)imag }; \ +#define ecl_def_ct_complex(name,real,imag,static,const) \ + static const struct ecl_complex name ## _data = { \ + (int8_t)t_complex, 0, 0, 0, \ + (cl_object)real, (cl_object)imag }; \ static const cl_object name = (cl_object)(& name ## _data) #define ecl_def_ct_vector(name,type,raw,len,static,const) \ diff --git a/src/h/ecl.h b/src/h/ecl.h index 5abdd1ae8..4fc320f56 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -17,14 +17,14 @@ #ifndef ECL_ECL_H #define ECL_ECL_H -#include /* size_t, pthread_t, pthread_mutex_t */ -#ifdef __OpenBSD__ /* same, but for OpenBSD (bug in OpenBSD!) */ +#include /* size_t, pthread_t, pthread_mutex_t */ +#ifdef __OpenBSD__ /* same, but for OpenBSD (bug in OpenBSD!) */ # include #endif -#include /* NULL, ptrdiff_t */ -#include /* va_list */ -#include /* setjmp and buffers */ -#include /* FILE */ +#include /* NULL, ptrdiff_t */ +#include /* va_list */ +#include /* setjmp and buffers */ +#include /* FILE */ /* Microsoft VC++ does not have va_copy() */ #if defined(_MSC_VER) || !defined(va_copy) #define va_copy(dst, src) \ diff --git a/src/h/external.h b/src/h/external.h index 179c14fac..aa7f19501 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -14,105 +14,105 @@ extern "C" { typedef struct cl_env_struct *cl_env_ptr; struct cl_env_struct { - /* Flag for disabling interrupts while we call C library functions. */ - volatile int disable_interrupts; + /* Flag for disabling interrupts while we call C library functions. */ + volatile int disable_interrupts; - /* Array where values are returned by functions. */ - cl_index nvalues; - cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; + /* Array where values are returned by functions. */ + cl_index nvalues; + cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; /* Environment for calling closures, CLOS generic functions, etc */ cl_object function; - /* The four stacks in ECL. */ + /* The four stacks in ECL. */ - /* - * The lisp stack, which is used mainly for keeping the arguments of a - * function before it is invoked, and also by the compiler and by the - * reader when they are building some data structure. - */ - cl_index stack_size; - cl_object *stack; - cl_object *stack_top; - cl_object *stack_limit; + /* + * The lisp stack, which is used mainly for keeping the arguments of a + * function before it is invoked, and also by the compiler and by the + * reader when they are building some data structure. + */ + cl_index stack_size; + cl_object *stack; + cl_object *stack_top; + cl_object *stack_limit; - /* - * The BinDing Stack stores the bindings of special variables. - */ + /* + * The BinDing Stack stores the bindings of special variables. + */ #ifdef ECL_THREADS cl_index thread_local_bindings_size; cl_object *thread_local_bindings; - cl_object bindings_array; + cl_object bindings_array; #endif - cl_index bds_size; - struct ecl_bds_frame *bds_org; - struct ecl_bds_frame *bds_top; - struct ecl_bds_frame *bds_limit; + cl_index bds_size; + struct ecl_bds_frame *bds_org; + struct ecl_bds_frame *bds_top; + struct ecl_bds_frame *bds_limit; - /* - * The Invocation History Stack (IHS) keeps a list of the names of the - * functions that are invoked, together with their lexical - * environments. - */ - struct ecl_ihs_frame *ihs_top; + /* + * The Invocation History Stack (IHS) keeps a list of the names of the + * functions that are invoked, together with their lexical + * environments. + */ + struct ecl_ihs_frame *ihs_top; - /* - * The FRames Stack (FRS) is a list of frames or jump points, and it - * is used by different high-level constructs (BLOCK, TAGBODY, CATCH...) - * to set return points. - */ - cl_index frs_size; - struct ecl_frame *frs_org; - struct ecl_frame *frs_top; - struct ecl_frame *frs_limit; - struct ecl_frame *nlj_fr; + /* + * The FRames Stack (FRS) is a list of frames or jump points, and it + * is used by different high-level constructs (BLOCK, TAGBODY, CATCH...) + * to set return points. + */ + cl_index frs_size; + struct ecl_frame *frs_org; + struct ecl_frame *frs_top; + struct ecl_frame *frs_limit; + struct ecl_frame *nlj_fr; cl_index frame_id; - /* - * The following pointers to the C Stack are used to ensure that a - * recursive function does not enter an infinite loop and exhausts all - * memory. They will eventually disappear, because most operating - * systems already take care of this. - */ - char *cs_org; - char *cs_limit; - char *cs_barrier; - cl_index cs_size; + /* + * The following pointers to the C Stack are used to ensure that a + * recursive function does not enter an infinite loop and exhausts all + * memory. They will eventually disappear, because most operating + * systems already take care of this. + */ + char *cs_org; + char *cs_limit; + char *cs_barrier; + cl_index cs_size; - /* Private variables used by different parts of ECL: */ - /* ... the reader ... */ - cl_object string_pool; + /* Private variables used by different parts of ECL: */ + /* ... the reader ... */ + cl_object string_pool; - /* ... the compiler ... */ - struct cl_compiler_env *c_env; + /* ... the compiler ... */ + struct cl_compiler_env *c_env; - /* ... the formatter ... */ - cl_object fmt_aux_stream; + /* ... the formatter ... */ + cl_object fmt_aux_stream; - /* ... arithmetics ... */ - /* Note: if you change the size of these registers, change also - BIGNUM_REGISTER_SIZE in config.h */ - cl_object big_register[3]; + /* ... arithmetics ... */ + /* Note: if you change the size of these registers, change also + BIGNUM_REGISTER_SIZE in config.h */ + cl_object big_register[3]; - cl_object own_process; - cl_object pending_interrupt; - cl_object signal_queue; - cl_object signal_queue_spinlock; + cl_object own_process; + cl_object pending_interrupt; + cl_object signal_queue; + cl_object signal_queue_spinlock; void *default_sigmask; - /* The following is a hash table for caching invocations of - generic functions. In a multithreaded environment we must - queue operations in which the hash is cleared from updated - generic functions. */ + /* The following is a hash table for caching invocations of + generic functions. In a multithreaded environment we must + queue operations in which the hash is cleared from updated + generic functions. */ #ifdef CLOS - struct ecl_cache *method_cache; - struct ecl_cache *slot_cache; + struct ecl_cache *method_cache; + struct ecl_cache *slot_cache; #endif - /* foreign function interface */ + /* foreign function interface */ #ifdef HAVE_LIBFFI cl_index ffi_args_limit; - struct _ffi_type **ffi_types; + struct _ffi_type **ffi_types; union ecl_ffi_values *ffi_values; union ecl_ffi_values **ffi_values_ptrs; #endif @@ -120,26 +120,26 @@ struct cl_env_struct { void *fficall; #endif - /* Alternative stack for processing signals */ - void *altstack; - cl_index altstack_size; + /* Alternative stack for processing signals */ + void *altstack; + cl_index altstack_size; /* Floating point interrupts which are trapped */ int trap_fpe_bits; - /* Old exception filter. Needed by windows. */ - void *old_exception_filter; + /* Old exception filter. Needed by windows. */ + void *old_exception_filter; /* List of packages interned when loading a FASL but which have * to be explicitely created by the compiled code itself. */ - cl_object packages_to_be_created; + cl_object packages_to_be_created; cl_object packages_to_be_created_p; - /* Segmentation fault address */ - void *fault_address; + /* Segmentation fault address */ + void *fault_address; #ifdef ECL_THREADS - int cleanup; + int cleanup; #endif }; @@ -166,74 +166,74 @@ struct cl_env_struct { */ struct cl_core_struct { - cl_object packages; - cl_object lisp_package; - cl_object user_package; - cl_object keyword_package; - cl_object system_package; + cl_object packages; + cl_object lisp_package; + cl_object user_package; + cl_object keyword_package; + cl_object system_package; cl_object ext_package; #ifdef CLOS - cl_object clos_package; + cl_object clos_package; # ifdef ECL_CLOS_STREAMS - cl_object gray_package; + cl_object gray_package; # endif #endif - cl_object mp_package; + cl_object mp_package; cl_object c_package; - cl_object ffi_package; + cl_object ffi_package; - cl_object pathname_translations; + cl_object pathname_translations; cl_object library_pathname; - cl_object terminal_io; - cl_object null_stream; - cl_object standard_input; - cl_object standard_output; - cl_object error_output; - cl_object standard_readtable; - cl_object dispatch_reader; - cl_object default_dispatch_macro; + cl_object terminal_io; + cl_object null_stream; + cl_object standard_input; + cl_object standard_output; + cl_object error_output; + cl_object standard_readtable; + cl_object dispatch_reader; + cl_object default_dispatch_macro; - cl_object char_names; - cl_object null_string; + cl_object char_names; + cl_object null_string; - cl_object plus_half; - cl_object minus_half; - cl_object imag_unit; - cl_object minus_imag_unit; - cl_object imag_two; - cl_object singlefloat_zero; - cl_object doublefloat_zero; - cl_object singlefloat_minus_zero; - cl_object doublefloat_minus_zero; + cl_object plus_half; + cl_object minus_half; + cl_object imag_unit; + cl_object minus_imag_unit; + cl_object imag_two; + cl_object singlefloat_zero; + cl_object doublefloat_zero; + cl_object singlefloat_minus_zero; + cl_object doublefloat_minus_zero; #ifdef ECL_LONG_FLOAT - cl_object longfloat_zero; - cl_object longfloat_minus_zero; + cl_object longfloat_zero; + cl_object longfloat_minus_zero; #endif - cl_object gensym_prefix; - cl_object gentemp_prefix; - cl_object gentemp_counter; + cl_object gensym_prefix; + cl_object gentemp_prefix; + cl_object gentemp_counter; - cl_object Jan1st1970UT; + cl_object Jan1st1970UT; - cl_object system_properties; - cl_object setf_definitions; + cl_object system_properties; + cl_object setf_definitions; #ifdef ECL_THREADS - cl_object processes; - cl_object processes_spinlock; - cl_object global_lock; + cl_object processes; + cl_object processes_spinlock; + cl_object global_lock; cl_object error_lock; cl_object global_env_lock; #endif - cl_object libraries; + cl_object libraries; - cl_index max_heap_size; - cl_object bytes_consed; - cl_object gc_counter; - bool gc_stats; - int path_max; + cl_index max_heap_size; + cl_object bytes_consed; + cl_object gc_counter; + bool gc_stats; + int path_max; #ifdef GBC_BOEHM char *safety_region; #endif @@ -244,9 +244,9 @@ struct cl_core_struct { cl_index last_var_index; cl_object reused_indices; #endif - cl_object slash; + cl_object slash; - cl_object compiler_dispatch; + cl_object compiler_dispatch; cl_object rehash_size; cl_object rehash_threshold; @@ -254,7 +254,7 @@ struct cl_core_struct { cl_object external_processes; cl_object external_processes_lock; - cl_object known_signals; + cl_object known_signals; }; extern ECL_API struct cl_core_struct cl_core; @@ -309,14 +309,14 @@ extern ECL_API void ecl_dealloc(void *p); extern ECL_API cl_object si_mangle_name _ECL_ARGS((cl_narg narg, cl_object symbol, ...)); typedef union { - struct { - const char *name; - int type; - void *fun; - short narg; - cl_object value; - } init; - struct ecl_symbol data; + struct { + const char *name; + int type; + void *fun; + short narg; + cl_object value; + } init; + struct ecl_symbol data; } cl_symbol_initializer; extern ECL_API cl_symbol_initializer cl_symbols[]; extern ECL_API cl_index cl_num_symbols_in_core; @@ -393,9 +393,9 @@ extern ECL_API void ecl_clear_compiler_properties(cl_object sym); /* big.c */ -#define _ecl_big_register0() ecl_process_env()->big_register[0] -#define _ecl_big_register1() ecl_process_env()->big_register[1] -#define _ecl_big_register2() ecl_process_env()->big_register[2] +#define _ecl_big_register0() ecl_process_env()->big_register[0] +#define _ecl_big_register1() ecl_process_env()->big_register[1] +#define _ecl_big_register2() ecl_process_env()->big_register[2] extern ECL_API cl_object _ecl_fix_times_fix(cl_fixnum x, cl_fixnum y); extern ECL_API cl_object _ecl_big_register_copy(cl_object x); extern ECL_API cl_object _ecl_big_register_normalize(cl_object x); @@ -669,9 +669,9 @@ extern ECL_API void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_ /* file.c */ -#define ECL_LISTEN_NO_CHAR 0 -#define ECL_LISTEN_AVAILABLE 1 -#define ECL_LISTEN_EOF -1 +#define ECL_LISTEN_NO_CHAR 0 +#define ECL_LISTEN_AVAILABLE 1 +#define ECL_LISTEN_EOF -1 extern ECL_API cl_object cl_make_synonym_stream(cl_object sym); extern ECL_API cl_object cl_synonym_stream_symbol(cl_object strm); @@ -944,33 +944,33 @@ extern ECL_API cl_object si_quit _ECL_ARGS((cl_narg narg, ...)) /*ecl_attr_noret extern ECL_API cl_object si_exit _ECL_ARGS((cl_narg narg, ...)) ecl_attr_noreturn; typedef enum { - ECL_OPT_INCREMENTAL_GC = 0, - ECL_OPT_TRAP_SIGSEGV, - ECL_OPT_TRAP_SIGFPE, - ECL_OPT_TRAP_SIGINT, - ECL_OPT_TRAP_SIGILL, - ECL_OPT_TRAP_SIGBUS, + ECL_OPT_INCREMENTAL_GC = 0, + ECL_OPT_TRAP_SIGSEGV, + ECL_OPT_TRAP_SIGFPE, + ECL_OPT_TRAP_SIGINT, + ECL_OPT_TRAP_SIGILL, + ECL_OPT_TRAP_SIGBUS, ECL_OPT_TRAP_SIGPIPE, ECL_OPT_TRAP_SIGCHLD, - ECL_OPT_TRAP_INTERRUPT_SIGNAL, - ECL_OPT_SIGNAL_HANDLING_THREAD, - ECL_OPT_SIGNAL_QUEUE_SIZE, - ECL_OPT_BOOTED, - ECL_OPT_BIND_STACK_SIZE, - ECL_OPT_BIND_STACK_SAFETY_AREA, - ECL_OPT_FRAME_STACK_SIZE, - ECL_OPT_FRAME_STACK_SAFETY_AREA, - ECL_OPT_LISP_STACK_SIZE, - ECL_OPT_LISP_STACK_SAFETY_AREA, - ECL_OPT_C_STACK_SIZE, - ECL_OPT_C_STACK_SAFETY_AREA, - ECL_OPT_SIGALTSTACK_SIZE, - ECL_OPT_HEAP_SIZE, - ECL_OPT_HEAP_SAFETY_AREA, + ECL_OPT_TRAP_INTERRUPT_SIGNAL, + ECL_OPT_SIGNAL_HANDLING_THREAD, + ECL_OPT_SIGNAL_QUEUE_SIZE, + ECL_OPT_BOOTED, + ECL_OPT_BIND_STACK_SIZE, + ECL_OPT_BIND_STACK_SAFETY_AREA, + ECL_OPT_FRAME_STACK_SIZE, + ECL_OPT_FRAME_STACK_SAFETY_AREA, + ECL_OPT_LISP_STACK_SIZE, + ECL_OPT_LISP_STACK_SAFETY_AREA, + ECL_OPT_C_STACK_SIZE, + ECL_OPT_C_STACK_SAFETY_AREA, + ECL_OPT_SIGALTSTACK_SIZE, + ECL_OPT_HEAP_SIZE, + ECL_OPT_HEAP_SAFETY_AREA, ECL_OPT_THREAD_INTERRUPT_SIGNAL, ECL_OPT_SET_GMP_MEMORY_FUNCTIONS, - ECL_OPT_USE_SETMODE_ON_FILES, - ECL_OPT_LIMIT + ECL_OPT_USE_SETMODE_ON_FILES, + ECL_OPT_LIMIT } ecl_option; extern ECL_API const char *ecl_self; @@ -1177,22 +1177,22 @@ extern ECL_API int ecl_number_compare(cl_object x, cl_object y); /* num_log.c */ -#define ECL_BOOLCLR 0 -#define ECL_BOOLAND 01 -#define ECL_BOOLANDC2 02 -#define ECL_BOOL1 03 -#define ECL_BOOLANDC1 04 -#define ECL_BOOL2 05 -#define ECL_BOOLXOR 06 -#define ECL_BOOLIOR 07 -#define ECL_BOOLNOR 010 -#define ECL_BOOLEQV 011 -#define ECL_BOOLC2 012 -#define ECL_BOOLORC2 013 -#define ECL_BOOLC1 014 -#define ECL_BOOLORC1 015 -#define ECL_BOOLNAND 016 -#define ECL_BOOLSET 017 +#define ECL_BOOLCLR 0 +#define ECL_BOOLAND 01 +#define ECL_BOOLANDC2 02 +#define ECL_BOOL1 03 +#define ECL_BOOLANDC1 04 +#define ECL_BOOL2 05 +#define ECL_BOOLXOR 06 +#define ECL_BOOLIOR 07 +#define ECL_BOOLNOR 010 +#define ECL_BOOLEQV 011 +#define ECL_BOOLC2 012 +#define ECL_BOOLORC2 013 +#define ECL_BOOLC1 014 +#define ECL_BOOLORC1 015 +#define ECL_BOOLNAND 016 +#define ECL_BOOLSET 017 extern ECL_API cl_object cl_lognand(cl_object x, cl_object y); extern ECL_API cl_object cl_lognor(cl_object x, cl_object y); diff --git a/src/h/internal.h b/src/h/internal.h index 595d0a243..4350f454c 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -21,7 +21,7 @@ extern "C" { #endif /* -------------------------------------------------------------------- * - * FUNCTIONS, VARIABLES AND TYPES NOT FOR GENERAL USE * + * FUNCTIONS, VARIABLES AND TYPES NOT FOR GENERAL USE * * -------------------------------------------------------------------- */ #define unlikely_if(x) if (ecl_unlikely(x)) @@ -101,17 +101,17 @@ extern void ecl_displace(cl_object from, cl_object to, cl_object offset); /* compiler.d */ struct cl_compiler_env { - cl_object variables; /* Variables, tags, functions, etc: the env. */ - cl_object macros; /* Macros and function bindings */ - cl_fixnum lexical_level; /* =0 if toplevel form */ - cl_object constants; /* Constants for this form */ - cl_object load_time_forms; /* Constants that have to be rebuilt */ - cl_object lex_env; /* Lexical env. for eval-when */ - cl_object code_walker; /* Value of SI:*CODE-WALKER* */ - cl_index env_depth; - cl_index env_size; + cl_object variables; /* Variables, tags, functions, etc: the env. */ + cl_object macros; /* Macros and function bindings */ + cl_fixnum lexical_level; /* =0 if toplevel form */ + cl_object constants; /* Constants for this form */ + cl_object load_time_forms; /* Constants that have to be rebuilt */ + cl_object lex_env; /* Lexical env. for eval-when */ + cl_object code_walker; /* Value of SI:*CODE-WALKER* */ + cl_index env_depth; + cl_index env_size; int mode; - bool stepping; + bool stepping; }; typedef struct cl_compiler_env *cl_compiler_env_ptr; @@ -120,12 +120,12 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr; #ifdef ECL_UNICODE #define ECL_UCS_NONCHARACTER(c) \ - (((c) >= 0xFDD0 && (c) <= 0xFDEF) || \ - (((c) & 0xFFFF) >= 0xFFFE && (((c) & 0xFFFF) <= 0xFFFF))) + (((c) >= 0xFDD0 && (c) <= 0xFDEF) || \ + (((c) & 0xFFFF) >= 0xFFFE && (((c) & 0xFFFF) <= 0xFFFF))) #define ECL_UCS_PRIVATE(c) \ - (((c) >= 0xE000 && (c) <= 0xF8FF) || \ - ((c) >= 0xF0000 && (c) <= 0xFFFD) || \ - ((c) >= 0x100000 && (c) <= 0x10FFFD)) + (((c) >= 0xE000 && (c) <= 0xF8FF) || \ + ((c) >= 0xF0000 && (c) <= 0xFFFD) || \ + ((c) >= 0x100000 && (c) <= 0x10FFFD)) #define ECL_UCS_HIGH_SURROGATE(c) ((c) >= 0xD800 && (c) <= 0xDBFF) #define ECL_UCS_LOW_SURROGATE(c) ((c) >= 0xDC00 && (c) <= 0xDFFF) #endif @@ -138,24 +138,24 @@ extern cl_object _ecl_strerror(int code); /* eval.d */ #define _ecl_funcall5(fun, a, b, c, d) \ - ecl_function_dispatch(ecl_process_env(), (fun))(4, (a),(b),(c),(d)) + ecl_function_dispatch(ecl_process_env(), (fun))(4, (a),(b),(c),(d)) #define _ecl_funcall4(fun, a, b, c) \ - ecl_function_dispatch(ecl_process_env(), (fun))(3, (a),(b),(c)) + ecl_function_dispatch(ecl_process_env(), (fun))(3, (a),(b),(c)) #define _ecl_funcall3(fun, a, b) \ - ecl_function_dispatch(ecl_process_env(), (fun))(2, (a),(b)) + ecl_function_dispatch(ecl_process_env(), (fun))(2, (a),(b)) #define _ecl_funcall2(fun, a) \ - ecl_function_dispatch(ecl_process_env(), (fun))(1, (a)) + ecl_function_dispatch(ecl_process_env(), (fun))(1, (a)) #define _ecl_funcall1(fun) \ - ecl_function_dispatch(ecl_process_env(), (fun))(0) + ecl_function_dispatch(ecl_process_env(), (fun))(0) extern cl_object si_constantp_inner _ECL_ARGS((cl_narg narg, cl_object form, ...)); extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form, ...)); /* interpreter.d */ -#define ECL_BUILD_STACK_FRAME(env,name,frame) \ - struct ecl_stack_frame frame;\ - cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0); +#define ECL_BUILD_STACK_FRAME(env,name,frame) \ + struct ecl_stack_frame frame;\ + cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0); #ifdef ECL_USE_VARARG_AS_POINTER #define ECL_STACK_FRAME_FROM_VA_LIST(e,f,va) do { \ @@ -231,13 +231,13 @@ extern void _ecl_dump_c_backtrace(); /* ffi.d */ struct ecl_fficall { - char *buffer_sp; - size_t buffer_size; - union ecl_ffi_values output; - enum ecl_ffi_calling_convention cc; - struct ecl_fficall_reg *registers; - char buffer[ECL_FFICALL_LIMIT]; - cl_object cstring; + char *buffer_sp; + size_t buffer_size; + union ecl_ffi_values output; + enum ecl_ffi_calling_convention cc; + struct ecl_fficall_reg *registers; + char buffer[ECL_FFICALL_LIMIT]; + cl_object cstring; }; extern enum ecl_ffi_tag ecl_foreign_type_code(cl_object type); @@ -264,11 +264,11 @@ extern void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_conv * Otherwise, it would be complicated to implement file-position and * seek operations. */ -#define OPEN_R "rb" -#define OPEN_W "wb" -#define OPEN_RW "r+b" -#define OPEN_A "ab" -#define OPEN_RA "a+b" +#define OPEN_R "rb" +#define OPEN_W "wb" +#define OPEN_RW "r+b" +#define OPEN_A "ab" +#define OPEN_RA "a+b" #define ECL_FILE_STREAM_P(strm) \ (ECL_ANSI_STREAM_P(strm) && (strm)->stream.mode < ecl_smm_synonym) @@ -365,8 +365,8 @@ extern bool _ecl_will_print_as_hash(cl_object o); extern cl_object _ecl_ensure_buffer(cl_object buffer, cl_fixnum length); extern void _ecl_string_push_c_string(cl_object s, const char *c); -#define ECL_PPRINT_QUEUE_SIZE 128 -#define ECL_PPRINT_INDENTATION_STACK_SIZE 256 +#define ECL_PPRINT_QUEUE_SIZE 128 +#define ECL_PPRINT_INDENTATION_STACK_SIZE 256 extern void cl_write_object(cl_object x, cl_object stream); @@ -396,18 +396,18 @@ extern void cl_write_object(cl_object x, cl_object stream); const cl_object __ecl_the_lock = lock; \ ecl_disable_interrupts_env(the_env); \ mp_get_lock_wait(__ecl_the_lock); \ - ECL_UNWIND_PROTECT_BEGIN(__ecl_the_env); \ - ecl_enable_interrupts_env(__ecl_the_env); + ECL_UNWIND_PROTECT_BEGIN(__ecl_the_env); \ + ecl_enable_interrupts_env(__ecl_the_env); # define ECL_WITH_LOCK_END \ ECL_UNWIND_PROTECT_EXIT { \ mp_giveup_lock(__ecl_the_lock); \ } ECL_UNWIND_PROTECT_END; } -# define ECL_WITH_SPINLOCK_BEGIN(the_env,lock) { \ - const cl_env_ptr __ecl_the_env = (the_env); \ - cl_object *__ecl_the_lock = (lock); \ +# define ECL_WITH_SPINLOCK_BEGIN(the_env,lock) { \ + const cl_env_ptr __ecl_the_env = (the_env); \ + cl_object *__ecl_the_lock = (lock); \ ecl_get_spinlock(__ecl_the_env, __ecl_the_lock); -# define ECL_WITH_SPINLOCK_END \ - ecl_giveup_spinlock(__ecl_the_lock); } +# define ECL_WITH_SPINLOCK_END \ + ecl_giveup_spinlock(__ecl_the_lock); } #else # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) # define ECL_WITH_GLOBAL_LOCK_END @@ -435,9 +435,9 @@ extern void cl_write_object(cl_object x, cl_object stream); /* read.d */ #ifdef ECL_UNICODE -#define RTABSIZE 256 /* read table size */ +#define RTABSIZE 256 /* read table size */ #else -#define RTABSIZE ECL_CHAR_CODE_LIMIT /* read table size */ +#define RTABSIZE ECL_CHAR_CODE_LIMIT /* read table size */ #endif extern cl_object si_make_backq_vector(cl_object dim, cl_object data, cl_object stream); @@ -464,11 +464,11 @@ extern cl_object ecl_deserialize(uint8_t *data); /* stacks.d */ #define CL_NEWENV_BEGIN {\ - const cl_env_ptr the_env = ecl_process_env(); \ - cl_index __i = ecl_stack_push_values(the_env); \ + const cl_env_ptr the_env = ecl_process_env(); \ + cl_index __i = ecl_stack_push_values(the_env); \ #define CL_NEWENV_END \ - ecl_stack_pop_values(the_env,__i); } + ecl_stack_pop_values(the_env,__i); } extern void ecl_cs_set_org(cl_env_ptr env); @@ -482,8 +482,8 @@ extern ECL_API cl_object mp_break_suspend_loop(); /* time.d */ struct ecl_timeval { - cl_index tv_usec; - cl_index tv_sec; + cl_index tv_usec; + cl_index tv_sec; }; extern void ecl_get_internal_real_time(struct ecl_timeval *time); diff --git a/src/h/legacy.h b/src/h/legacy.h index c5e0c5f59..6d74a195a 100644 --- a/src/h/legacy.h +++ b/src/h/legacy.h @@ -19,29 +19,29 @@ /* * LEGACY */ -#define CHARACTERP(o) ECL_CHARACTERP(o) -#define BASE_CHAR_P(o) ECL_BASE_CHAR_P(o) -#define BASE_CHAR_CODE_P(o) ECL_BASE_CHAR_CODE_P(o) -#define CODE_CHAR(o) ECL_CODE_CHAR(o) -#define CHAR_CODE(o) ECL_CHAR_CODE(o) -#define REAL_TYPE(t) ECL_REAL_TYPE_P(t) -#define IMMEDIATE(o) ECL_IMMEDIATE(o) -#define IMMEDIATE_TAG ECL_IMMEDIATE_TAG +#define CHARACTERP(o) ECL_CHARACTERP(o) +#define BASE_CHAR_P(o) ECL_BASE_CHAR_P(o) +#define BASE_CHAR_CODE_P(o) ECL_BASE_CHAR_CODE_P(o) +#define CODE_CHAR(o) ECL_CODE_CHAR(o) +#define CHAR_CODE(o) ECL_CHAR_CODE(o) +#define REAL_TYPE(t) ECL_REAL_TYPE_P(t) +#define IMMEDIATE(o) ECL_IMMEDIATE(o) +#define IMMEDIATE_TAG ECL_IMMEDIATE_TAG -#define FIXNUM_TAG t_fixnum -#define MAKE_FIXNUM(n) ecl_make_fixnum(n) -#define FIXNUM_MINUSP(n) ecl_fixnum_minusp(n) -#define FIXNUM_PLUSP(n) ecl_fixnum_plusp(n) -#define fix(o) ecl_fixnum(o) -#define FIXNUMP(o) ECL_FIXNUMP(o) +#define FIXNUM_TAG t_fixnum +#define MAKE_FIXNUM(n) ecl_make_fixnum(n) +#define FIXNUM_MINUSP(n) ecl_fixnum_minusp(n) +#define FIXNUM_PLUSP(n) ecl_fixnum_plusp(n) +#define fix(o) ecl_fixnum(o) +#define FIXNUMP(o) ECL_FIXNUMP(o) -#define sf(obje) (obje)->SF.SFVAL -#define df(obje) (obje)->DF.DFVAL +#define sf(obje) (obje)->SF.SFVAL +#define df(obje) (obje)->DF.DFVAL #define make_shortfloat(x) ecl_make_shortfloat(x); -#define big_dim big_num->_mp_alloc -#define big_size big_num->_mp_size -#define big_limbs big_num->_mp_d +#define big_dim big_num->_mp_alloc +#define big_size big_num->_mp_size +#define big_limbs big_num->_mp_d #define cl_def_c_function_va(sym,function) ecl_def_c_function_va(sym,function) #define cl_def_c_function(sym,function,narg) ecl_def_c_function(sym,function,narg) @@ -138,11 +138,11 @@ #define CHAR_CODE_LIMIT ECL_CHAR_CODE_LIMIT -#define NVALUES cl_env.nvalues -#define VALUES(n) cl_env.values[n] -#define return0() return ((NVALUES = 0),ECL_NIL) -#define return1(x) return ((VALUES(0)=(x)),(NVALUES=1),VALUES(0)) -#define returnn(x) return x +#define NVALUES cl_env.nvalues +#define VALUES(n) cl_env.values[n] +#define return0() return ((NVALUES = 0),ECL_NIL) +#define return1(x) return ((VALUES(0)=(x)),(NVALUES=1),VALUES(0)) +#define returnn(x) return x #define CL_UNWIND_PROTECT_BEGIN ECL_UNWIND_PROTECT_BEGIN #define CL_UNWIND_PROTECT_END ECL_UNWIND_PROTECT_END @@ -158,36 +158,36 @@ typedef struct ecl_bds_frame *bds_ptr; typedef struct ecl_ihs_frame *ihs_ptr; -#define LISTP(x) ECL_LISTP(x) -#define CONSP(x) ECL_CONSP(x) -#define ATOM(x) ECL_ATOM(x) -#define SYMBOLP(x) ECL_SYMBOLP(x) +#define LISTP(x) ECL_LISTP(x) +#define CONSP(x) ECL_CONSP(x) +#define ATOM(x) ECL_ATOM(x) +#define SYMBOLP(x) ECL_SYMBOLP(x) -enum { /* stream mode */ - smm_input, /* input */ - smm_input_file, /* input */ - smm_output, /* output */ - smm_output_file, /* output */ - smm_io, /* input-output */ - smm_io_file, /* input-output */ - smm_synonym, /* synonym */ - smm_broadcast, /* broadcast */ - smm_concatenated, /* concatenated */ - smm_two_way, /* two way */ - smm_echo, /* echo */ - smm_string_input, /* string input */ - smm_string_output, /* string output */ - smm_probe, /* probe (only used in open_stream()) */ +enum { /* stream mode */ + smm_input, /* input */ + smm_input_file, /* input */ + smm_output, /* output */ + smm_output_file, /* output */ + smm_io, /* input-output */ + smm_io_file, /* input-output */ + smm_synonym, /* synonym */ + smm_broadcast, /* broadcast */ + smm_concatenated, /* concatenated */ + smm_two_way, /* two way */ + smm_echo, /* echo */ + smm_string_input, /* string input */ + smm_string_output, /* string output */ + smm_probe, /* probe (only used in open_stream()) */ #if defined(WSOCK) - smm_input_wsock, /* input socket (Win32) */ - smm_output_wsock, /* output socket (Win32) */ - smm_io_wsock, /* input/output socket (Win32) */ + smm_input_wsock, /* input socket (Win32) */ + smm_output_wsock, /* output socket (Win32) */ + smm_io_wsock, /* input/output socket (Win32) */ #endif #if defined(MS_WINDOWS_HOST) - smm_io_wcon, /* windows console (Win32) */ + smm_io_wcon, /* windows console (Win32) */ #endif - smm_sequence_input, /* sequence input */ - smm_sequence_output /* sequence output */ + smm_sequence_input, /* sequence input */ + smm_sequence_output /* sequence output */ }; #define Cnil ECL_NIL diff --git a/src/h/number.h b/src/h/number.h index d472bb147..3eda51ba8 100644 --- a/src/h/number.h +++ b/src/h/number.h @@ -20,7 +20,7 @@ extern "C" { #endif -#define ECL_BIG_REGISTER_SIZE 32 +#define ECL_BIG_REGISTER_SIZE 32 #define ECL_WITH_TEMP_BIGNUM(name,n) \ mp_limb_t name##data[n]; \ @@ -44,50 +44,50 @@ extern ECL_API _ecl_big_binary_op _ecl_big_boole_operator(int op); #define _ecl_big_set_fixnum(x, f) mpz_set_si((x)->big.big_num,(f)) #define _ecl_big_set_index(x, f) mpz_set_ui((x)->big.big_num,(f)) #endif -#define _ecl_big_init2(x,size) mpz_init2((x)->big.big_num,(size)*GMP_LIMB_BITS) -#define _ecl_big_clear(x) mpz_clear((x)->big.big_num) -#define _ecl_big_set(x,y) mpz_set((x)->big.big_num,(y)->big.big_num) -#define _ecl_big_odd_p(x) ((mpz_get_ui(x->big.big_num) & 1) != 0) -#define _ecl_big_even_p(x) ((mpz_get_ui(x->big.big_num) & 1) == 0) -#define _ecl_big_zerop(x) (ECL_BIGNUM_SIZE(x) == 0) -#define _ecl_big_sign(x) ECL_BIGNUM_SIZE(x) -#define _ecl_big_compare(x, y) mpz_cmp(x->big.big_num, y->big.big_num) +#define _ecl_big_init2(x,size) mpz_init2((x)->big.big_num,(size)*GMP_LIMB_BITS) +#define _ecl_big_clear(x) mpz_clear((x)->big.big_num) +#define _ecl_big_set(x,y) mpz_set((x)->big.big_num,(y)->big.big_num) +#define _ecl_big_odd_p(x) ((mpz_get_ui(x->big.big_num) & 1) != 0) +#define _ecl_big_even_p(x) ((mpz_get_ui(x->big.big_num) & 1) == 0) +#define _ecl_big_zerop(x) (ECL_BIGNUM_SIZE(x) == 0) +#define _ecl_big_sign(x) ECL_BIGNUM_SIZE(x) +#define _ecl_big_compare(x, y) mpz_cmp(x->big.big_num, y->big.big_num) #define _ecl_big_complement(z, x) mpz_neg((z)->big.big_num,(x)->big.big_num) -#define _ecl_big_add(z, x, y) mpz_add((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) -#define _ecl_big_sub(z, x, y) mpz_sub((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) -#define _ecl_big_mul(z, x, y) mpz_mul((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) -#define _ecl_big_add_ui(z, x, i) mpz_add_ui(z->big.big_num, x->big.big_num, i) -#define _ecl_big_sub_ui(z, x, i) mpz_sub_ui(z->big.big_num, x->big.big_num, i) -#define _ecl_big_mul_ui(z, x, y) mpz_mul_ui((z)->big.big_num,(x)->big.big_num,(y)) -#define _ecl_big_div_ui(z, x, y) mpz_div_ui((z)->big.big_num,(x)->big.big_num,(y)) -#define _ecl_big_mul_si(z, x, y) mpz_mul_si((z)->big.big_num,(x)->big.big_num,(y)) -#define _ecl_big_set_ui(x, i) mpz_set_ui(x->big.big_num, (unsigned long int)i) -#define _ecl_big_set_si(x, i) mpz_set_si(x->big.big_num, (long int)i) -#define _ecl_big_to_double(x) mpz_get_d(x->big.big_num) -#define _ecl_big_to_long(x) mpz_get_si(x->big.big_num) -#define _ecl_big_to_ulong(x) mpz_get_ui(x->big.big_num) -#define _ecl_big_cmp_si(x,y) mpz_cmp_si((x)->big.big_num,(y)) -#define _ecl_big_tdiv_q(q, x, y) mpz_tdiv_q((q)->big.big_num,(x)->big.big_num,(y)->big.big_num) -#define _ecl_big_tdiv_q_ui(q, x, y) mpz_tdiv_q_ui((q)->big.big_num, (x)->big.big_num, (y)) -#define _ecl_big_set_d(x, d) mpz_set_d((x)->big.big_num, (d)) +#define _ecl_big_add(z, x, y) mpz_add((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) +#define _ecl_big_sub(z, x, y) mpz_sub((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) +#define _ecl_big_mul(z, x, y) mpz_mul((z)->big.big_num,(x)->big.big_num,(y)->big.big_num) +#define _ecl_big_add_ui(z, x, i) mpz_add_ui(z->big.big_num, x->big.big_num, i) +#define _ecl_big_sub_ui(z, x, i) mpz_sub_ui(z->big.big_num, x->big.big_num, i) +#define _ecl_big_mul_ui(z, x, y) mpz_mul_ui((z)->big.big_num,(x)->big.big_num,(y)) +#define _ecl_big_div_ui(z, x, y) mpz_div_ui((z)->big.big_num,(x)->big.big_num,(y)) +#define _ecl_big_mul_si(z, x, y) mpz_mul_si((z)->big.big_num,(x)->big.big_num,(y)) +#define _ecl_big_set_ui(x, i) mpz_set_ui(x->big.big_num, (unsigned long int)i) +#define _ecl_big_set_si(x, i) mpz_set_si(x->big.big_num, (long int)i) +#define _ecl_big_to_double(x) mpz_get_d(x->big.big_num) +#define _ecl_big_to_long(x) mpz_get_si(x->big.big_num) +#define _ecl_big_to_ulong(x) mpz_get_ui(x->big.big_num) +#define _ecl_big_cmp_si(x,y) mpz_cmp_si((x)->big.big_num,(y)) +#define _ecl_big_tdiv_q(q, x, y) mpz_tdiv_q((q)->big.big_num,(x)->big.big_num,(y)->big.big_num) +#define _ecl_big_tdiv_q_ui(q, x, y) mpz_tdiv_q_ui((q)->big.big_num, (x)->big.big_num, (y)) +#define _ecl_big_set_d(x, d) mpz_set_d((x)->big.big_num, (d)) #if ECL_CAN_INLINE static ECL_INLINE cl_fixnum ecl_to_fix(cl_object f) { - if (ecl_unlikely(!ECL_FIXNUMP(f))) - FEtype_error_fixnum(f); - return ecl_fixnum(f); + if (ecl_unlikely(!ECL_FIXNUMP(f))) + FEtype_error_fixnum(f); + return ecl_fixnum(f); } static ECL_INLINE cl_index ecl_to_size(cl_object f) { - cl_fixnum aux = 0; - if (ecl_unlikely(!ECL_FIXNUMP(f) || ((aux = ecl_fixnum(f)) < 0))) - FEtype_error_size(f); - return aux; + cl_fixnum aux = 0; + if (ecl_unlikely(!ECL_FIXNUMP(f) || ((aux = ecl_fixnum(f)) < 0))) + FEtype_error_size(f); + return aux; } #else extern ECL_API cl_fixnum ecl_fixnum_value(cl_object f); diff --git a/src/h/object.h b/src/h/object.h index d429298ae..00d78b8d6 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -20,11 +20,11 @@ extern "C" { #endif /* - Integer and boolean types (see config.h) + Integer and boolean types (see config.h) */ -#define TRUE 1 /* boolean true value */ -#define FALSE 0 /* boolean false value */ +#define TRUE 1 /* boolean true value */ +#define FALSE 0 /* boolean false value */ #if !defined(__cplusplus) && !defined(bool) typedef int bool; @@ -34,74 +34,74 @@ typedef unsigned char byte; /* #define ECL_EXTERNALIZABLE */ /* - Implementation types. + Implementation types. Verify that it matches printer/write_ugly.d */ typedef enum { - t_start = 0, - t_list = 1, - /* The most specific numeric types come first. Assumed by - some routines, like cl_expt */ - t_character = 2, /* immediate character */ - t_fixnum = 3, /* immediate fixnum */ - t_bignum = 4, - t_ratio, - t_singlefloat, - t_doublefloat, + t_start = 0, + t_list = 1, + /* The most specific numeric types come first. Assumed by + some routines, like cl_expt */ + t_character = 2, /* immediate character */ + t_fixnum = 3, /* immediate fixnum */ + t_bignum = 4, + t_ratio, + t_singlefloat, + t_doublefloat, #ifdef ECL_LONG_FLOAT - t_longfloat, + t_longfloat, #endif - t_complex, - t_symbol, - t_package, - t_hashtable, - t_array, - t_vector, + t_complex, + t_symbol, + t_package, + t_hashtable, + t_array, + t_vector, #ifdef ECL_UNICODE - t_string, + t_string, #endif - t_base_string, - t_bitvector, - t_stream, - t_random, - t_readtable, - t_pathname, - t_bytecodes, - t_bclosure, - t_cfun, - t_cfunfixed, - t_cclosure, + t_base_string, + t_bitvector, + t_stream, + t_random, + t_readtable, + t_pathname, + t_bytecodes, + t_bclosure, + t_cfun, + t_cfunfixed, + t_cclosure, #ifdef CLOS - t_instance, - t_structure = t_instance, + t_instance, + t_structure = t_instance, #else - t_structure, + t_structure, #endif /* CLOS */ #ifdef ECL_THREADS - t_process, - t_lock, - t_rwlock, - t_condition_variable, + t_process, + t_lock, + t_rwlock, + t_condition_variable, t_semaphore, t_barrier, t_mailbox, #endif - t_codeblock, - t_foreign, - t_frame, - t_weak_pointer, + t_codeblock, + t_foreign, + t_frame, + t_weak_pointer, #ifdef ECL_SSE2 - t_sse_pack, + t_sse_pack, #endif - t_end, - t_other, - t_contiguous, /* contiguous block */ - FREE = 127 /* free object */ + t_end, + t_other, + t_contiguous, /* contiguous block */ + FREE = 127 /* free object */ } cl_type; /* - Definition of the type of LISP objects. + Definition of the type of LISP objects. */ typedef union cl_lispunion *cl_object; typedef cl_object cl_return; @@ -110,26 +110,26 @@ typedef cl_object (*cl_objectfn)(cl_narg narg, ...); typedef cl_object (*cl_objectfn_fixed)(); /* - OBJect NULL value. - It should not coincide with any legal object value. + OBJect NULL value. + It should not coincide with any legal object value. */ -#define OBJNULL ((cl_object)NULL) +#define OBJNULL ((cl_object)NULL) /* - Definition of each implementation type. + Definition of each implementation type. */ -#define ECL_TAG_BITS 2 -#define ECL_IMMEDIATE(o) ((cl_fixnum)(o) & 3) -#define ECL_IMMEDIATE_TAG 3 +#define ECL_TAG_BITS 2 +#define ECL_IMMEDIATE(o) ((cl_fixnum)(o) & 3) +#define ECL_IMMEDIATE_TAG 3 #define ecl_to_bool(x) ((x)!=ECL_NIL) #define ecl_make_bool(x) ((x)? ECL_T : ECL_NIL) -/* Immediate fixnums: */ -#define ECL_FIXNUM_TAG t_fixnum +/* Immediate fixnums: */ +#define ECL_FIXNUM_TAG t_fixnum #define ECL_FIXNUMP(o) (ECL_IMMEDIATE(o) == t_fixnum) -#define ecl_make_fixnum(n) ((cl_object)(((cl_fixnum)(n) << 2) | t_fixnum)) +#define ecl_make_fixnum(n) ((cl_object)(((cl_fixnum)(n) << 2) | t_fixnum)) #define ecl_fixnum_lower(a,b) ((cl_fixnum)(a) < (cl_fixnum)(b)) #define ecl_fixnum_greater(a,b) ((cl_fixnum)(a) > (cl_fixnum)(b)) #define ecl_fixnum_leq(a,b) ((cl_fixnum)(a) <= (cl_fixnum)(b)) @@ -138,38 +138,38 @@ typedef cl_object (*cl_objectfn_fixed)(); #define ecl_fixnum_minusp(a) ((cl_fixnum)(a) < (cl_fixnum)(0)) #define ecl_fixnum(a) (((cl_fixnum)(a)) >> 2) -/* Immediate characters: */ -#define ECL_CHARACTER_TAG t_character -#define ECL_CHARACTERP(o) (ECL_IMMEDIATE(o) == t_character) +/* Immediate characters: */ +#define ECL_CHARACTER_TAG t_character +#define ECL_CHARACTERP(o) (ECL_IMMEDIATE(o) == t_character) #ifdef ECL_UNICODE -#define ECL_BASE_CHAR_P(obje) ((((cl_fixnum)(obje)) & 0xFFFFFC03) == ECL_CHARACTER_TAG) -#define ECL_BASE_CHAR_CODE_P(x) ((x & ~((cl_fixnum)0xFF)) == 0) -#define ECL_CODE_CHAR(c) ((cl_object)(((cl_fixnum)(c << 2)|ECL_CHARACTER_TAG))) -#define ECL_CHAR_CODE(obje) (((cl_fixnum)(obje)) >> 2) +#define ECL_BASE_CHAR_P(obje) ((((cl_fixnum)(obje)) & 0xFFFFFC03) == ECL_CHARACTER_TAG) +#define ECL_BASE_CHAR_CODE_P(x) ((x & ~((cl_fixnum)0xFF)) == 0) +#define ECL_CODE_CHAR(c) ((cl_object)(((cl_fixnum)(c << 2)|ECL_CHARACTER_TAG))) +#define ECL_CHAR_CODE(obje) (((cl_fixnum)(obje)) >> 2) #else -#define ECL_BASE_CHAR_P(o) ECL_CHARACTERP(o) -#define ECL_CODE_CHAR(c) ((cl_object)(((cl_fixnum)((c & 0xff) << 2)|ECL_CHARACTER_TAG))) -#define ECL_CHAR_CODE(obje) ((((cl_fixnum)(obje)) >> 2) & 0xff) +#define ECL_BASE_CHAR_P(o) ECL_CHARACTERP(o) +#define ECL_CODE_CHAR(c) ((cl_object)(((cl_fixnum)((c & 0xff) << 2)|ECL_CHARACTER_TAG))) +#define ECL_CHAR_CODE(obje) ((((cl_fixnum)(obje)) >> 2) & 0xff) #endif -#define ECL_CHAR_CODE_RETURN 13 -#define ECL_CHAR_CODE_NEWLINE 10 -#define ECL_CHAR_CODE_LINEFEED 10 +#define ECL_CHAR_CODE_RETURN 13 +#define ECL_CHAR_CODE_NEWLINE 10 +#define ECL_CHAR_CODE_LINEFEED 10 -#define ECL_NUMBER_TYPE_P(t) (t >= t_fixnum && t <= t_complex) -#define ECL_REAL_TYPE_P(t) (t >= t_fixnum && t < t_complex) -#define ECL_ARRAYP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_array && (x)->d.t <= t_bitvector) -#define ECL_VECTORP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_vector && (x)->d.t <= t_bitvector) +#define ECL_NUMBER_TYPE_P(t) (t >= t_fixnum && t <= t_complex) +#define ECL_REAL_TYPE_P(t) (t >= t_fixnum && t < t_complex) +#define ECL_ARRAYP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_array && (x)->d.t <= t_bitvector) +#define ECL_VECTORP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_vector && (x)->d.t <= t_bitvector) #define ECL_BIT_VECTOR_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_bitvector)) #ifdef ECL_UNICODE -#define ECL_STRINGP(x) ((ECL_IMMEDIATE(x) == 0) && \ +#define ECL_STRINGP(x) ((ECL_IMMEDIATE(x) == 0) && \ ((x)->d.t == t_base_string || (x)->d.t == t_string)) #define ECL_EXTENDED_STRING_P(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t == t_string) #else -#define ECL_STRINGP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_base_string)) +#define ECL_STRINGP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_base_string)) #define ECL_EXTENDED_STRING_P(x) 0 #endif -#define ECL_BASE_STRING_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_base_string)) -#define ECL_HASH_TABLE_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_hashtable)) +#define ECL_BASE_STRING_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_base_string)) +#define ECL_HASH_TABLE_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_hashtable)) #define ECL_BIGNUMP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_bignum)) #define ECL_COMPLEXP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_complex)) #define ECL_RANDOM_STATE_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_random)) @@ -186,110 +186,110 @@ typedef cl_object (*cl_objectfn_fixed)(); #define ECL_SSE_PACK_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_sse_pack)) #endif -#define _ECL_HDR int8_t t, m, padding1, padding2 -#define _ECL_HDR1(field) int8_t t, m, field, padding -#define _ECL_HDR2(field1,field2) int8_t t, m, field1, field2 +#define _ECL_HDR int8_t t, m, padding1, padding2 +#define _ECL_HDR1(field) int8_t t, m, field, padding +#define _ECL_HDR2(field1,field2) int8_t t, m, field1, field2 struct ecl_singlefloat { - _ECL_HDR; - float SFVAL; /* singlefloat value */ + _ECL_HDR; + float SFVAL; /* singlefloat value */ }; #define ecl_single_float(o) ((o)->SF.SFVAL) struct ecl_doublefloat { - _ECL_HDR; - double DFVAL; /* doublefloat value */ + _ECL_HDR; + double DFVAL; /* doublefloat value */ }; #define ecl_double_float(o) ((o)->DF.DFVAL) #ifdef ECL_LONG_FLOAT struct ecl_long_float { - _ECL_HDR; - long double value; + _ECL_HDR; + long double value; }; #define ecl_long_float(o) ((o)->longfloat.value) #endif struct ecl_bignum { - _ECL_HDR; - mpz_t big_num; + _ECL_HDR; + mpz_t big_num; }; -#define ECL_BIGNUM_DIM(x) ((x)->big.big_num->_mp_alloc) -#define ECL_BIGNUM_SIZE(x) ((x)->big.big_num->_mp_size) -#define ECL_BIGNUM_LIMBS(x) ((x)->big.big_num->_mp_d) +#define ECL_BIGNUM_DIM(x) ((x)->big.big_num->_mp_alloc) +#define ECL_BIGNUM_SIZE(x) ((x)->big.big_num->_mp_size) +#define ECL_BIGNUM_LIMBS(x) ((x)->big.big_num->_mp_d) struct ecl_ratio { - _ECL_HDR; - cl_object den; /* denominator, must be an integer */ - cl_object num; /* numerator, must be an integer */ + _ECL_HDR; + cl_object den; /* denominator, must be an integer */ + cl_object num; /* numerator, must be an integer */ }; #ifdef _MSC_VER -#undef complex /* Otherwise we cannot do x->complex.real */ +#undef complex /* Otherwise we cannot do x->complex.real */ #endif struct ecl_complex { - _ECL_HDR; - cl_object real; /* real part, must be a number */ - cl_object imag; /* imaginary part, must be a number */ + _ECL_HDR; + cl_object real; /* real part, must be a number */ + cl_object imag; /* imaginary part, must be a number */ }; -enum ecl_stype { /* symbol type */ - ecl_stp_ordinary = 0, - ecl_stp_constant = 1, +enum ecl_stype { /* symbol type */ + ecl_stp_ordinary = 0, + ecl_stp_constant = 1, ecl_stp_special = 2, - ecl_stp_macro = 4, - ecl_stp_special_form = 8 + ecl_stp_macro = 4, + ecl_stp_special_form = 8 }; -#define ECL_NIL ((cl_object)t_list) -#define ECL_NIL_SYMBOL ((cl_object)cl_symbols) -#define ECL_T ((cl_object)(cl_symbols+1)) -#define ECL_UNBOUND ((cl_object)(cl_symbols+2)) -#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3)) -#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+4)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+5)) -#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) +#define ECL_NIL ((cl_object)t_list) +#define ECL_NIL_SYMBOL ((cl_object)cl_symbols) +#define ECL_T ((cl_object)(cl_symbols+1)) +#define ECL_UNBOUND ((cl_object)(cl_symbols+2)) +#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3)) +#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+4)) +#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+5)) +#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) struct ecl_symbol { - _ECL_HDR2(stype, dynamic);/* symbol type, special-variable-p */ - cl_object value; /* global value of the symbol */ - /* Coincides with cons.car */ - cl_object gfdef; /* global function definition */ - /* For a macro, */ - /* its expansion function */ - /* is to be stored. */ - /* Coincides with cons.cdr */ - cl_object plist; /* property list */ - /* This field coincides with cons.car */ - cl_object name; /* print name */ - cl_object hpack; /* home package */ - /* ECL_NIL for uninterned symbols */ + _ECL_HDR2(stype, dynamic);/* symbol type, special-variable-p */ + cl_object value; /* global value of the symbol */ + /* Coincides with cons.car */ + cl_object gfdef; /* global function definition */ + /* For a macro, */ + /* its expansion function */ + /* is to be stored. */ + /* Coincides with cons.cdr */ + cl_object plist; /* property list */ + /* This field coincides with cons.car */ + cl_object name; /* print name */ + cl_object hpack; /* home package */ + /* ECL_NIL for uninterned symbols */ #ifdef ECL_THREADS - cl_index binding; /* index into the bindings array */ + cl_index binding; /* index into the bindings array */ #endif }; -#define ECL_SYM_FUN(sym) ((sym)->symbol.gfdef) +#define ECL_SYM_FUN(sym) ((sym)->symbol.gfdef) struct ecl_package { - _ECL_HDR1(locked); - cl_object name; /* package name, a string */ - cl_object nicknames; /* nicknames, list of strings */ - cl_object shadowings; /* shadowing symbol list */ - cl_object uses; /* use-list of packages */ - cl_object usedby; /* used-by-list of packages */ - cl_object internal; /* hashtable for internal symbols */ - cl_object external; /* hashtable for external symbols */ + _ECL_HDR1(locked); + cl_object name; /* package name, a string */ + cl_object nicknames; /* nicknames, list of strings */ + cl_object shadowings; /* shadowing symbol list */ + cl_object uses; /* use-list of packages */ + cl_object usedby; /* used-by-list of packages */ + cl_object internal; /* hashtable for internal symbols */ + cl_object external; /* hashtable for external symbols */ }; /* - The values returned by intern and find_symbol. - File_symbol may return 0. + The values returned by intern and find_symbol. + File_symbol may return 0. */ enum { - ECL_INTERNAL = 1, - ECL_EXTERNAL, - ECL_INHERITED + ECL_INTERNAL = 1, + ECL_EXTERNAL, + ECL_INHERITED }; /* @@ -317,16 +317,16 @@ enum { #define ECL_ATOM(x) (Null(x) || !LISTP(x)) #define ECL_SYMBOLP(x) (Null(x) || ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_symbol))) -#define ECL_PTR_CONS(x) (cl_object)((char*)(x) + t_list) -#define ECL_CONS_PTR(x) ((struct ecl_cons *)((char *)(x) - t_list)) -#define ECL_CONS_CAR(x) (*(cl_object*)((char *)(x) - t_list)) -#define ECL_CONS_CDR(x) (*(cl_object*)((char *)(x) + sizeof(cl_object) - t_list)) -#define ECL_RPLACA(x,v) (ECL_CONS_CAR(x)=(v)) -#define ECL_RPLACD(x,v) (ECL_CONS_CDR(x)=(v)) +#define ECL_PTR_CONS(x) (cl_object)((char*)(x) + t_list) +#define ECL_CONS_PTR(x) ((struct ecl_cons *)((char *)(x) - t_list)) +#define ECL_CONS_CAR(x) (*(cl_object*)((char *)(x) - t_list)) +#define ECL_CONS_CDR(x) (*(cl_object*)((char *)(x) + sizeof(cl_object) - t_list)) +#define ECL_RPLACA(x,v) (ECL_CONS_CAR(x)=(v)) +#define ECL_RPLACD(x,v) (ECL_CONS_CDR(x)=(v)) struct ecl_cons { - cl_object car; /* car */ - cl_object cdr; /* cdr */ + cl_object car; /* car */ + cl_object cdr; /* cdr */ }; #else #define ECL_LISTP(x) (ECL_IMMEDIATE(x)? Null(x) : ((x)->d.t == t_list)) @@ -334,62 +334,62 @@ struct ecl_cons { #define ECL_ATOM(x) (ECL_IMMEDIATE(x) || ((x)->d.t != t_list)) #define ECL_SYMBOLP(x) (Null(x) || ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_symbol))) -#define ECL_CONS_CAR(x) ((x)->cons.car) -#define ECL_CONS_CDR(x) ((x)->cons.cdr) -#define ECL_RPLACA(x,v) (ECL_CONS_CAR(x)=(v)) -#define ECL_RPLACD(x,v) (ECL_CONS_CDR(x)=(v)) +#define ECL_CONS_CAR(x) ((x)->cons.car) +#define ECL_CONS_CDR(x) ((x)->cons.cdr) +#define ECL_RPLACA(x,v) (ECL_CONS_CAR(x)=(v)) +#define ECL_RPLACD(x,v) (ECL_CONS_CDR(x)=(v)) struct ecl_cons { - _ECL_HDR; - cl_object car; /* car */ - cl_object cdr; /* cdr */ + _ECL_HDR; + cl_object car; /* car */ + cl_object cdr; /* cdr */ }; #endif -enum ecl_httest { /* hash table key test function */ - ecl_htt_eq, /* eq */ - ecl_htt_eql, /* eql */ - ecl_htt_equal, /* equal */ - ecl_htt_equalp, /* equalp */ - ecl_htt_pack /* symbol hash */ +enum ecl_httest { /* hash table key test function */ + ecl_htt_eq, /* eq */ + ecl_htt_eql, /* eql */ + ecl_htt_equal, /* equal */ + ecl_htt_equalp, /* equalp */ + ecl_htt_pack /* symbol hash */ }; enum ecl_htweak { - ecl_htt_not_weak = 0, - ecl_htt_weak_key, - ecl_htt_weak_value, - ecl_htt_weak_key_and_value + ecl_htt_not_weak = 0, + ecl_htt_weak_key, + ecl_htt_weak_value, + ecl_htt_weak_key_and_value }; -struct ecl_hashtable_entry { /* hash table entry */ - cl_object key; /* key */ - cl_object value; /* value */ +struct ecl_hashtable_entry { /* hash table entry */ + cl_object key; /* key */ + cl_object value; /* value */ }; -struct ecl_hashtable { /* hash table header */ - _ECL_HDR2(test,weak); - struct ecl_hashtable_entry *data; /* pointer to the hash table */ - cl_index entries; /* number of entries */ - cl_index size; /* hash table size */ - cl_index limit; /* hash table threshold (integer value) */ - cl_object rehash_size; /* rehash size */ - cl_object threshold; /* rehash threshold */ - double factor; /* cached value of threshold */ - cl_object (*get)(cl_object, cl_object, cl_object); - cl_object (*set)(cl_object, cl_object, cl_object); - bool (*rem)(cl_object, cl_object); +struct ecl_hashtable { /* hash table header */ + _ECL_HDR2(test,weak); + struct ecl_hashtable_entry *data; /* pointer to the hash table */ + cl_index entries; /* number of entries */ + cl_index size; /* hash table size */ + cl_index limit; /* hash table threshold (integer value) */ + cl_object rehash_size; /* rehash size */ + cl_object threshold; /* rehash threshold */ + double factor; /* cached value of threshold */ + cl_object (*get)(cl_object, cl_object, cl_object); + cl_object (*set)(cl_object, cl_object, cl_object); + bool (*rem)(cl_object, cl_object); }; -typedef enum { /* array element type */ - ecl_aet_object, /* t */ - ecl_aet_sf, /* single-float */ - ecl_aet_df, /* double-float */ - ecl_aet_bit, /* bit */ - ecl_aet_fix, /* cl_fixnum */ - ecl_aet_index, /* cl_index */ - /* Below here, list types accepted by streams (i.e. OPEN) */ - ecl_aet_b8, /* byte8 */ - ecl_aet_i8, /* integer8 */ +typedef enum { /* array element type */ + ecl_aet_object, /* t */ + ecl_aet_sf, /* single-float */ + ecl_aet_df, /* double-float */ + ecl_aet_bit, /* bit */ + ecl_aet_fix, /* cl_fixnum */ + ecl_aet_index, /* cl_index */ + /* Below here, list types accepted by streams (i.e. OPEN) */ + ecl_aet_b8, /* byte8 */ + ecl_aet_i8, /* integer8 */ #ifdef ecl_uint16_t ecl_aet_b16, ecl_aet_i16, #endif @@ -400,20 +400,20 @@ typedef enum { /* array element type */ ecl_aet_b64, ecl_aet_i64, #endif #ifdef ECL_UNICODE - ecl_aet_ch, /* character */ + ecl_aet_ch, /* character */ #endif - ecl_aet_bc, /* base-char */ - ecl_aet_last_type = ecl_aet_bc + ecl_aet_bc, /* base-char */ + ecl_aet_last_type = ecl_aet_bc } cl_elttype; union ecl_array_data { - cl_object *t; + cl_object *t; ecl_base_char *bc; #ifdef ECL_UNICODE ecl_character *c; #endif - uint8_t *b8; - int8_t *i8; + uint8_t *b8; + int8_t *i8; #ifdef ecl_uint16_t ecl_uint16_t *b16; ecl_int16_t *i16; @@ -426,11 +426,11 @@ union ecl_array_data { ecl_uint64_t *b64; ecl_int64_t *i64; #endif - float *sf; - double *df; - cl_fixnum *fix; - cl_index *index; - byte *bit; + float *sf; + double *df; + cl_fixnum *fix; + cl_index *index; + byte *bit; }; #define ECL_FLAG_HAS_FILL_POINTER 1 @@ -438,169 +438,169 @@ union ecl_array_data { #define ECL_ADJUSTABLE_ARRAY_P(x) ((x)->array.flags & ECL_FLAG_ADJUSTABLE) #define ECL_ARRAY_HAS_FILL_POINTER_P(x) ((x)->array.flags & ECL_FLAG_HAS_FILL_POINTER) -struct ecl_array { /* array header */ - /* adjustable flag */ - /* has-fill-pointer flag */ - _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ - cl_object displaced; /* displaced */ - cl_index dim; /* dimension */ - cl_index *dims; /* table of dimensions */ - union ecl_array_data self; /* pointer to the array */ - byte offset; /* bitvector offset */ - byte rank; /* rank of array = # of dimensions */ +struct ecl_array { /* array header */ + /* adjustable flag */ + /* has-fill-pointer flag */ + _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ + cl_object displaced; /* displaced */ + cl_index dim; /* dimension */ + cl_index *dims; /* table of dimensions */ + union ecl_array_data self; /* pointer to the array */ + byte offset; /* bitvector offset */ + byte rank; /* rank of array = # of dimensions */ }; -struct ecl_vector { /* vector header */ - /* adjustable flag */ - /* has-fill-pointer flag */ - _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ - cl_object displaced; /* displaced */ - cl_index dim; /* dimension */ - cl_index fillp; /* fill pointer */ - /* For simple vectors, */ - /* v_fillp is equal to v_dim. */ - union ecl_array_data self; /* pointer to the vector */ - byte offset; +struct ecl_vector { /* vector header */ + /* adjustable flag */ + /* has-fill-pointer flag */ + _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ + cl_object displaced; /* displaced */ + cl_index dim; /* dimension */ + cl_index fillp; /* fill pointer */ + /* For simple vectors, */ + /* v_fillp is equal to v_dim. */ + union ecl_array_data self; /* pointer to the vector */ + byte offset; }; -struct ecl_base_string { /* string header */ - /* adjustable flag */ - /* has-fill-pointer flag */ - _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ - cl_object displaced; /* displaced */ - cl_index dim; /* dimension */ - /* string length */ - cl_index fillp; /* fill pointer */ - /* For simple strings, */ - /* st_fillp is equal to st_dim-1. */ - ecl_base_char *self; /* pointer to the string */ +struct ecl_base_string { /* string header */ + /* adjustable flag */ + /* has-fill-pointer flag */ + _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ + cl_object displaced; /* displaced */ + cl_index dim; /* dimension */ + /* string length */ + cl_index fillp; /* fill pointer */ + /* For simple strings, */ + /* st_fillp is equal to st_dim-1. */ + ecl_base_char *self; /* pointer to the string */ }; #ifdef ECL_UNICODE -struct ecl_string { /* string header */ - /* adjustable flag */ - /* has-fill-pointer flag */ - _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ - cl_object displaced; /* displaced */ - cl_index dim; /* dimension */ - /* string length */ - cl_index fillp; /* fill pointer */ - /* For simple strings, */ - /* st_fillp is equal to st_dim-1. */ - ecl_character *self; /* pointer to the string */ +struct ecl_string { /* string header */ + /* adjustable flag */ + /* has-fill-pointer flag */ + _ECL_HDR2(elttype,flags); /* array element type, has fill ptr, adjustable-p */ + cl_object displaced; /* displaced */ + cl_index dim; /* dimension */ + /* string length */ + cl_index fillp; /* fill pointer */ + /* For simple strings, */ + /* st_fillp is equal to st_dim-1. */ + ecl_character *self; /* pointer to the string */ }; #endif #ifdef CLOS -#define T_STRUCTURE t_instance -#define ECL_STRUCT_TYPE(x) ECL_CLASS_OF(x) -#define ECL_STRUCT_SLOTS(x) (x)->instance.slots -#define ECL_STRUCT_LENGTH(x) (x)->instance.length -#define ECL_STRUCT_SLOT(x,i) (x)->instance.slots[i] -#define ECL_STRUCT_NAME(x) ECL_CLASS_NAME(ECL_CLASS_OF(x)) +#define T_STRUCTURE t_instance +#define ECL_STRUCT_TYPE(x) ECL_CLASS_OF(x) +#define ECL_STRUCT_SLOTS(x) (x)->instance.slots +#define ECL_STRUCT_LENGTH(x) (x)->instance.length +#define ECL_STRUCT_SLOT(x,i) (x)->instance.slots[i] +#define ECL_STRUCT_NAME(x) ECL_CLASS_NAME(ECL_CLASS_OF(x)) #else -struct ecl_structure { /* structure header */ - _ECL_HDR; - cl_object name; /* structure name */ - cl_object *self; /* structure self */ - cl_fixnum length; /* structure length */ +struct ecl_structure { /* structure header */ + _ECL_HDR; + cl_object name; /* structure name */ + cl_object *self; /* structure self */ + cl_fixnum length; /* structure length */ }; -#define T_STRUCTURE t_structure -#define ECL_STRUCT_TYPE(x) x->str.name -#define ECL_STRUCT_SLOTS(x) (x)->str.self -#define ECL_STRUCT_LENGTH(x) (x)->str.length -#define ECL_STRUCT_SLOT(x,i) (x)->str.self[i] -#define ECL_STRUCT_NAME(x) x->str.name +#define T_STRUCTURE t_structure +#define ECL_STRUCT_TYPE(x) x->str.name +#define ECL_STRUCT_SLOTS(x) (x)->str.self +#define ECL_STRUCT_LENGTH(x) (x)->str.length +#define ECL_STRUCT_SLOT(x,i) (x)->str.self[i] +#define ECL_STRUCT_NAME(x) x->str.name #endif -enum ecl_smmode { /* stream mode */ - ecl_smm_input, /* input */ - ecl_smm_input_file, /* input */ - ecl_smm_output, /* output */ - ecl_smm_output_file, /* output */ - ecl_smm_io, /* input-output */ - ecl_smm_io_file, /* input-output */ - ecl_smm_synonym, /* synonym */ - ecl_smm_broadcast, /* broadcast */ - ecl_smm_concatenated, /* concatenated */ - ecl_smm_two_way, /* two way */ - ecl_smm_echo, /* echo */ - ecl_smm_string_input, /* string input */ - ecl_smm_string_output, /* string output */ - ecl_smm_probe, /* probe (only used in open_stream()) */ +enum ecl_smmode { /* stream mode */ + ecl_smm_input, /* input */ + ecl_smm_input_file, /* input */ + ecl_smm_output, /* output */ + ecl_smm_output_file, /* output */ + ecl_smm_io, /* input-output */ + ecl_smm_io_file, /* input-output */ + ecl_smm_synonym, /* synonym */ + ecl_smm_broadcast, /* broadcast */ + ecl_smm_concatenated, /* concatenated */ + ecl_smm_two_way, /* two way */ + ecl_smm_echo, /* echo */ + ecl_smm_string_input, /* string input */ + ecl_smm_string_output, /* string output */ + ecl_smm_probe, /* probe (only used in open_stream()) */ #if defined(ECL_WSOCK) - ecl_smm_input_wsock, /* input socket (Win32) */ - ecl_smm_output_wsock, /* output socket (Win32) */ - ecl_smm_io_wsock, /* input/output socket (Win32) */ + ecl_smm_input_wsock, /* input socket (Win32) */ + ecl_smm_output_wsock, /* output socket (Win32) */ + ecl_smm_io_wsock, /* input/output socket (Win32) */ #endif #if defined(ECL_MS_WINDOWS_HOST) - ecl_smm_io_wcon, /* windows console (Win32) */ + ecl_smm_io_wcon, /* windows console (Win32) */ #endif - ecl_smm_sequence_input, /* sequence input */ - ecl_smm_sequence_output /* sequence output */ + ecl_smm_sequence_input, /* sequence input */ + ecl_smm_sequence_output /* sequence output */ }; struct ecl_file_ops { - cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); - cl_index (*read_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index (*read_byte8)(cl_object strm, unsigned char *c, cl_index n); - void (*write_byte)(cl_object c, cl_object strm); - cl_object (*read_byte)(cl_object strm); + void (*write_byte)(cl_object c, cl_object strm); + cl_object (*read_byte)(cl_object strm); - int (*read_char)(cl_object strm); - int (*write_char)(cl_object strm, int c); - void (*unread_char)(cl_object strm, int c); - int (*peek_char)(cl_object strm); + int (*read_char)(cl_object strm); + int (*write_char)(cl_object strm, int c); + void (*unread_char)(cl_object strm, int c); + int (*peek_char)(cl_object strm); - cl_index (*read_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); - cl_index (*write_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); + cl_index (*read_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); + cl_index (*write_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); - int (*listen)(cl_object strm); - void (*clear_input)(cl_object strm); - void (*clear_output)(cl_object strm); - void (*finish_output)(cl_object strm); - void (*force_output)(cl_object strm); + int (*listen)(cl_object strm); + void (*clear_input)(cl_object strm); + void (*clear_output)(cl_object strm); + void (*finish_output)(cl_object strm); + void (*force_output)(cl_object strm); - int (*input_p)(cl_object strm); - int (*output_p)(cl_object strm); - int (*interactive_p)(cl_object strm); - cl_object (*element_type)(cl_object strm); + int (*input_p)(cl_object strm); + int (*output_p)(cl_object strm); + int (*interactive_p)(cl_object strm); + cl_object (*element_type)(cl_object strm); - cl_object (*length)(cl_object strm); - cl_object (*get_position)(cl_object strm); - cl_object (*set_position)(cl_object strm, cl_object pos); - int (*column)(cl_object strm); + cl_object (*length)(cl_object strm); + cl_object (*get_position)(cl_object strm); + cl_object (*set_position)(cl_object strm, cl_object pos); + int (*column)(cl_object strm); - cl_object (*close)(cl_object strm); + cl_object (*close)(cl_object strm); }; enum { - ECL_STREAM_BINARY = 0, - ECL_STREAM_FORMAT = 0xF, + ECL_STREAM_BINARY = 0, + ECL_STREAM_FORMAT = 0xF, #ifndef ECL_UNICODE - ECL_STREAM_DEFAULT_FORMAT = 1, + ECL_STREAM_DEFAULT_FORMAT = 1, #else - ECL_STREAM_DEFAULT_FORMAT = 2, - ECL_STREAM_ISO_8859_1 = 1, - ECL_STREAM_LATIN_1 = 1, - ECL_STREAM_UTF_8 = 2, - ECL_STREAM_UCS_2 = 3, - ECL_STREAM_UCS_2LE = 5 + 128, - ECL_STREAM_UCS_2BE = 5, - ECL_STREAM_UCS_4 = 6, - ECL_STREAM_UCS_4LE = 7 + 128, - ECL_STREAM_UCS_4BE = 7, - ECL_STREAM_USER_FORMAT = 8, - ECL_STREAM_US_ASCII = 10, + ECL_STREAM_DEFAULT_FORMAT = 2, + ECL_STREAM_ISO_8859_1 = 1, + ECL_STREAM_LATIN_1 = 1, + ECL_STREAM_UTF_8 = 2, + ECL_STREAM_UCS_2 = 3, + ECL_STREAM_UCS_2LE = 5 + 128, + ECL_STREAM_UCS_2BE = 5, + ECL_STREAM_UCS_4 = 6, + ECL_STREAM_UCS_4LE = 7 + 128, + ECL_STREAM_UCS_4BE = 7, + ECL_STREAM_USER_FORMAT = 8, + ECL_STREAM_US_ASCII = 10, #endif - ECL_STREAM_CR = 16, - ECL_STREAM_LF = 32, - ECL_STREAM_SIGNED_BYTES = 64, - ECL_STREAM_LITTLE_ENDIAN = 128, - ECL_STREAM_C_STREAM = 256, - ECL_STREAM_MIGHT_SEEK = 512, - ECL_STREAM_CLOSE_COMPONENTS = 1024 + ECL_STREAM_CR = 16, + ECL_STREAM_LF = 32, + ECL_STREAM_SIGNED_BYTES = 64, + ECL_STREAM_LITTLE_ENDIAN = 128, + ECL_STREAM_C_STREAM = 256, + ECL_STREAM_MIGHT_SEEK = 512, + ECL_STREAM_CLOSE_COMPONENTS = 1024 }; typedef int (*cl_eformat_decoder)(cl_object stream); @@ -613,160 +613,160 @@ typedef cl_index (*cl_eformat_read_byte8)(cl_object object, unsigned char *buffe (ECL_IMMEDIATE(o) == 0 && ((o)->d.t == t_stream) && ((o)->stream.mode == (m))) struct ecl_stream { - _ECL_HDR2(mode,closed); /* stream mode of enum smmode */ - /* closed stream? */ - struct ecl_file_ops *ops; /* dispatch table */ + _ECL_HDR2(mode,closed); /* stream mode of enum smmode */ + /* closed stream? */ + struct ecl_file_ops *ops; /* dispatch table */ union { - FILE *stream; /* ANSI C streams */ - cl_fixnum descriptor; /* POSIX files */ + FILE *stream; /* ANSI C streams */ + cl_fixnum descriptor; /* POSIX files */ } file; - cl_object object0; /* some object */ - cl_object object1; /* some object */ - cl_object byte_stack; /* buffer for unread bytes */ - cl_index column; /* file column */ - cl_fixnum last_char; /* last character read */ - cl_fixnum last_code[2]; /* actual composition of last character */ - cl_fixnum int0; /* some int */ - cl_fixnum int1; /* some int */ - cl_index byte_size; /* size of byte in binary streams */ - cl_fixnum last_op; /* 0: unknown, 1: reading, -1: writing */ - char *buffer; /* buffer for FILE */ - cl_object format; /* external format */ - cl_eformat_encoder encoder; - cl_eformat_decoder decoder; - cl_object format_table; - int flags; /* character table, flags, etc */ - ecl_character eof_char; + cl_object object0; /* some object */ + cl_object object1; /* some object */ + cl_object byte_stack; /* buffer for unread bytes */ + cl_index column; /* file column */ + cl_fixnum last_char; /* last character read */ + cl_fixnum last_code[2]; /* actual composition of last character */ + cl_fixnum int0; /* some int */ + cl_fixnum int1; /* some int */ + cl_index byte_size; /* size of byte in binary streams */ + cl_fixnum last_op; /* 0: unknown, 1: reading, -1: writing */ + char *buffer; /* buffer for FILE */ + cl_object format; /* external format */ + cl_eformat_encoder encoder; + cl_eformat_decoder decoder; + cl_object format_table; + int flags; /* character table, flags, etc */ + ecl_character eof_char; }; struct ecl_random { - _ECL_HDR; - cl_object value; /* random state value */ + _ECL_HDR; + cl_object value; /* random state value */ }; -enum ecl_chattrib { /* character attribute */ - cat_whitespace, /* whitespace */ - cat_terminating, /* terminating macro */ - cat_non_terminating, /* non-terminating macro */ - cat_single_escape, /* single-escape */ - cat_multiple_escape, /* multiple-escape */ - cat_constituent /* constituent */ +enum ecl_chattrib { /* character attribute */ + cat_whitespace, /* whitespace */ + cat_terminating, /* terminating macro */ + cat_non_terminating, /* non-terminating macro */ + cat_single_escape, /* single-escape */ + cat_multiple_escape, /* multiple-escape */ + cat_constituent /* constituent */ }; -struct ecl_readtable_entry { /* read table entry */ - enum ecl_chattrib syntax_type; /* character attribute */ - cl_object dispatch; /* a macro, a hash or NIL */ +struct ecl_readtable_entry { /* read table entry */ + enum ecl_chattrib syntax_type; /* character attribute */ + cl_object dispatch; /* a macro, a hash or NIL */ }; enum ecl_readtable_case { - ecl_case_upcase, - ecl_case_downcase, - ecl_case_invert, - ecl_case_preserve + ecl_case_upcase, + ecl_case_downcase, + ecl_case_invert, + ecl_case_preserve }; -struct ecl_readtable { /* read table */ - _ECL_HDR1(locked); - enum ecl_readtable_case read_case; /* readtable-case */ - struct ecl_readtable_entry *table; /* read table itself */ +struct ecl_readtable { /* read table */ + _ECL_HDR1(locked); + enum ecl_readtable_case read_case; /* readtable-case */ + struct ecl_readtable_entry *table; /* read table itself */ #ifdef ECL_UNICODE - cl_object hash; /* hash for values outside base-char range */ + cl_object hash; /* hash for values outside base-char range */ #endif }; struct ecl_pathname { - _ECL_HDR1(logical); /* logical pathname? */ - cl_object host; /* host */ - cl_object device; /* device */ - cl_object directory; /* directory */ - cl_object name; /* name */ - cl_object type; /* type */ - cl_object version; /* version */ + _ECL_HDR1(logical); /* logical pathname? */ + cl_object host; /* host */ + cl_object device; /* device */ + cl_object directory; /* directory */ + cl_object name; /* name */ + cl_object type; /* type */ + cl_object version; /* version */ }; struct ecl_codeblock { - _ECL_HDR2(self_destruct,locked); /* delete DLL after gc */ - /* do not garbage collect this library */ - void *handle; /* handle returned by dlopen */ - void *entry; /* entry point */ - cl_object *data; /* data vector */ - int data_size; - cl_object *temp_data; /* data vector for toplevel forms */ - int temp_data_size; - const cl_object *data_text; /* strings with objects to be defined */ - cl_object next; /* next codeblock within same library */ - cl_object name; - cl_object links; /* list of symbols with linking calls */ - cl_index cfuns_size; /* number of functions defined */ - const struct ecl_cfun *cfuns; - cl_object source; /* common debug information for this block */ - cl_object refs; /* reference counter for the library */ - cl_object error; /* error message when loading */ + _ECL_HDR2(self_destruct,locked); /* delete DLL after gc */ + /* do not garbage collect this library */ + void *handle; /* handle returned by dlopen */ + void *entry; /* entry point */ + cl_object *data; /* data vector */ + int data_size; + cl_object *temp_data; /* data vector for toplevel forms */ + int temp_data_size; + const cl_object *data_text; /* strings with objects to be defined */ + cl_object next; /* next codeblock within same library */ + cl_object name; + cl_object links; /* list of symbols with linking calls */ + cl_index cfuns_size; /* number of functions defined */ + const struct ecl_cfun *cfuns; + cl_object source; /* common debug information for this block */ + cl_object refs; /* reference counter for the library */ + cl_object error; /* error message when loading */ }; struct ecl_bytecodes { - _ECL_HDR; - cl_object name; /* function name */ - cl_object definition; /* function definition in list form */ - cl_objectfn entry; /* entry address (must match the position of + _ECL_HDR; + cl_object name; /* function name */ + cl_object definition; /* function definition in list form */ + cl_objectfn entry; /* entry address (must match the position of * the equivalent field in cfun) */ - cl_index code_size; /* number of bytecodes */ - char *code; /* the intermediate language */ - cl_object data; /* non-inmediate constants used in the code */ - cl_object file; /* file where it was defined... */ - cl_object file_position;/* and where it was created */ + cl_index code_size; /* number of bytecodes */ + char *code; /* the intermediate language */ + cl_object data; /* non-inmediate constants used in the code */ + cl_object file; /* file where it was defined... */ + cl_object file_position;/* and where it was created */ }; struct ecl_bclosure { - _ECL_HDR; - cl_object code; - cl_object lex; - cl_objectfn entry; /* entry address */ + _ECL_HDR; + cl_object code; + cl_object lex; + cl_objectfn entry; /* entry address */ }; -struct ecl_cfun { /* compiled function header */ - _ECL_HDR1(narg); - cl_object name; /* compiled function name */ - cl_object block; /* descriptor of C code block for GC */ - cl_objectfn entry; /* entry address */ - cl_object file; /* file where it was defined... */ - cl_object file_position;/* and where it was created */ +struct ecl_cfun { /* compiled function header */ + _ECL_HDR1(narg); + cl_object name; /* compiled function name */ + cl_object block; /* descriptor of C code block for GC */ + cl_objectfn entry; /* entry address */ + cl_object file; /* file where it was defined... */ + cl_object file_position;/* and where it was created */ }; -struct ecl_cfunfixed { /* compiled function header */ - _ECL_HDR1(narg); - cl_object name; /* compiled function name */ - cl_object block; /* descriptor of C code block for GC */ - cl_objectfn entry; /* entry address (must match the position of +struct ecl_cfunfixed { /* compiled function header */ + _ECL_HDR1(narg); + cl_object name; /* compiled function name */ + cl_object block; /* descriptor of C code block for GC */ + cl_objectfn entry; /* entry address (must match the position of * the equivalent field in cfun) */ - cl_objectfn_fixed entry_fixed; /* entry address */ - cl_object file; /* file where it was defined... */ - cl_object file_position;/* and where it was created */ + cl_objectfn_fixed entry_fixed; /* entry address */ + cl_object file; /* file where it was defined... */ + cl_object file_position;/* and where it was created */ }; -struct ecl_cclosure { /* compiled closure header */ - _ECL_HDR; - cl_object env; /* environment */ - cl_object block; /* descriptor of C code block for GC */ - cl_objectfn entry; /* entry address (must match the position of +struct ecl_cclosure { /* compiled closure header */ + _ECL_HDR; + cl_object env; /* environment */ + cl_object block; /* descriptor of C code block for GC */ + cl_objectfn entry; /* entry address (must match the position of * the equivalent field in cfun) */ - cl_object file; /* file where it was defined... */ - cl_object file_position;/* and where it was created */ + cl_object file; /* file where it was defined... */ + cl_object file_position;/* and where it was created */ }; #define ECL_FFICALL_LIMIT 256 enum ecl_ffi_tag { - ECL_FFI_CHAR = 0, - ECL_FFI_UNSIGNED_CHAR, - ECL_FFI_BYTE, - ECL_FFI_UNSIGNED_BYTE, - ECL_FFI_SHORT, - ECL_FFI_UNSIGNED_SHORT, - ECL_FFI_INT, - ECL_FFI_UNSIGNED_INT, - ECL_FFI_LONG, - ECL_FFI_UNSIGNED_LONG, + ECL_FFI_CHAR = 0, + ECL_FFI_UNSIGNED_CHAR, + ECL_FFI_BYTE, + ECL_FFI_UNSIGNED_BYTE, + ECL_FFI_SHORT, + ECL_FFI_UNSIGNED_SHORT, + ECL_FFI_INT, + ECL_FFI_UNSIGNED_INT, + ECL_FFI_LONG, + ECL_FFI_UNSIGNED_LONG, #ifdef ecl_uint8_t ECL_FFI_INT8_T, ECL_FFI_UINT8_T, @@ -787,25 +787,25 @@ enum ecl_ffi_tag { ECL_FFI_LONG_LONG, ECL_FFI_UNSIGNED_LONG_LONG, #endif - ECL_FFI_POINTER_VOID, - ECL_FFI_CSTRING, - ECL_FFI_OBJECT, - ECL_FFI_FLOAT, - ECL_FFI_DOUBLE, - ECL_FFI_VOID + ECL_FFI_POINTER_VOID, + ECL_FFI_CSTRING, + ECL_FFI_OBJECT, + ECL_FFI_FLOAT, + ECL_FFI_DOUBLE, + ECL_FFI_VOID }; union ecl_ffi_values { - char c; - unsigned char uc; - int8_t b; - uint8_t ub; - int i; - unsigned int ui; - short s; - unsigned short us; - long l; - unsigned long ul; + char c; + unsigned char uc; + int8_t b; + uint8_t ub; + int i; + unsigned int ui; + short s; + unsigned short us; + long l; + unsigned long ul; #ifdef ecl_uint8_t ecl_int8_t i8; ecl_uint8_t u8; @@ -827,43 +827,43 @@ union ecl_ffi_values { ecl_ulong_long_t ull; unsigned long l2[2]; #endif - void *pv; - char *pc; - cl_object o; - float f; - double d; + void *pv; + char *pc; + cl_object o; + float f; + double d; }; enum ecl_ffi_calling_convention { - ECL_FFI_CC_CDECL = 0, - ECL_FFI_CC_STDCALL + ECL_FFI_CC_CDECL = 0, + ECL_FFI_CC_STDCALL }; -struct ecl_foreign { /* user defined datatype */ - _ECL_HDR; - cl_object tag; /* a tag identifying the type */ - cl_index size; /* the amount of memory allocated */ - char *data; /* the data itself */ +struct ecl_foreign { /* user defined datatype */ + _ECL_HDR; + cl_object tag; /* a tag identifying the type */ + cl_index size; /* the amount of memory allocated */ + char *data; /* the data itself */ }; struct ecl_stack_frame { - _ECL_HDR; - cl_object *stack; /* Is this relative to the lisp stack? */ - cl_object *base; /* Start of frame */ - cl_index size; /* Number of arguments */ - struct cl_env_struct *env; + _ECL_HDR; + cl_object *stack; /* Is this relative to the lisp stack? */ + cl_object *base; /* Start of frame */ + cl_index size; /* Number of arguments */ + struct cl_env_struct *env; }; -struct ecl_weak_pointer { /* weak pointer to value */ - _ECL_HDR; - cl_object value; +struct ecl_weak_pointer { /* weak pointer to value */ + _ECL_HDR; + cl_object value; }; /* - dummy type + dummy type */ struct ecl_dummy { - _ECL_HDR; + _ECL_HDR; }; #ifdef ECL_THREADS @@ -874,77 +874,77 @@ enum { ECL_PROCESS_EXITING }; struct ecl_process { - _ECL_HDR; - cl_object name; - cl_object function; - cl_object args; - struct cl_env_struct *env; - cl_object interrupt; - cl_object initial_bindings; + _ECL_HDR; + cl_object name; + cl_object function; + cl_object args; + struct cl_env_struct *env; + cl_object interrupt; + cl_object initial_bindings; cl_object parent; - cl_object exit_barrier; + cl_object exit_barrier; cl_object exit_values; - cl_object woken_up; - cl_object queue_record; - cl_object start_spinlock; - cl_index phase; - pthread_t thread; - int trap_fpe_bits; + cl_object woken_up; + cl_object queue_record; + cl_object start_spinlock; + cl_index phase; + pthread_t thread; + int trap_fpe_bits; }; enum { - ECL_WAKEUP_ONE = 0, - ECL_WAKEUP_ALL = 1, - ECL_WAKEUP_RESET_FLAG = 2, - ECL_WAKEUP_KILL = 4, - ECL_WAKEUP_DELETE = 8 + ECL_WAKEUP_ONE = 0, + ECL_WAKEUP_ALL = 1, + ECL_WAKEUP_RESET_FLAG = 2, + ECL_WAKEUP_KILL = 4, + ECL_WAKEUP_DELETE = 8 }; struct ecl_queue { - _ECL_HDR; - cl_object list; - cl_object spinlock; + _ECL_HDR; + cl_object list; + cl_object spinlock; }; struct ecl_semaphore { - _ECL_HDR; - cl_object queue_list; - cl_object queue_spinlock; + _ECL_HDR; + cl_object queue_list; + cl_object queue_spinlock; cl_object name; - cl_fixnum counter; + cl_fixnum counter; }; struct ecl_barrier { - _ECL_HDR; - cl_object queue_list; - cl_object queue_spinlock; + _ECL_HDR; + cl_object queue_list; + cl_object queue_spinlock; cl_object name; - cl_fixnum count; - cl_fixnum arrivers_count; + cl_fixnum count; + cl_fixnum arrivers_count; }; struct ecl_lock { - _ECL_HDR1(recursive); - cl_object queue_list; - cl_object queue_spinlock; + _ECL_HDR1(recursive); + cl_object queue_list; + cl_object queue_spinlock; cl_object owner; /* thread holding the lock or NIL */ cl_object name; - cl_fixnum counter; + cl_fixnum counter; }; struct ecl_mailbox { - _ECL_HDR; - cl_object name; + _ECL_HDR; + cl_object name; cl_object data; cl_object reader_semaphore; cl_object writer_semaphore; - cl_index read_pointer; - cl_index write_pointer; - cl_index mask; + cl_index read_pointer; + cl_index write_pointer; + cl_index mask; }; struct ecl_rwlock { - _ECL_HDR; + _ECL_HDR; cl_object name; #ifdef ECL_RWLOCK pthread_rwlock_t mutex; @@ -955,153 +955,153 @@ struct ecl_rwlock { struct ecl_condition_variable { _ECL_HDR; - cl_object queue_list; - cl_object queue_spinlock; - cl_object lock; + cl_object queue_list; + cl_object queue_spinlock; + cl_object lock; }; #endif /* ECL_THREADS */ #ifdef CLOS -#define ECL_CLASS_OF(x) (x)->instance.clas -#define ECL_SPEC_FLAG(x) (x)->instance.slots[0] -#define ECL_SPEC_OBJECT(x) (x)->instance.slots[3] -#define ECL_CLASS_NAME(x) (x)->instance.slots[3+0] -#define ECL_CLASS_SUPERIORS(x) (x)->instance.slots[3+1] -#define ECL_CLASS_INFERIORS(x) (x)->instance.slots[3+2] -#define ECL_CLASS_SLOTS(x) (x)->instance.slots[3+3] -#define ECL_CLASS_CPL(x) (x)->instance.slots[3+4] -#define ECL_INSTANCEP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_instance)) -#define ECL_NOT_FUNCALLABLE 0 -#define ECL_STANDARD_DISPATCH 1 -#define ECL_RESTRICTED_DISPATCH 2 -#define ECL_READER_DISPATCH 3 -#define ECL_WRITER_DISPATCH 4 -#define ECL_USER_DISPATCH 5 +#define ECL_CLASS_OF(x) (x)->instance.clas +#define ECL_SPEC_FLAG(x) (x)->instance.slots[0] +#define ECL_SPEC_OBJECT(x) (x)->instance.slots[3] +#define ECL_CLASS_NAME(x) (x)->instance.slots[3+0] +#define ECL_CLASS_SUPERIORS(x) (x)->instance.slots[3+1] +#define ECL_CLASS_INFERIORS(x) (x)->instance.slots[3+2] +#define ECL_CLASS_SLOTS(x) (x)->instance.slots[3+3] +#define ECL_CLASS_CPL(x) (x)->instance.slots[3+4] +#define ECL_INSTANCEP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_instance)) +#define ECL_NOT_FUNCALLABLE 0 +#define ECL_STANDARD_DISPATCH 1 +#define ECL_RESTRICTED_DISPATCH 2 +#define ECL_READER_DISPATCH 3 +#define ECL_WRITER_DISPATCH 4 +#define ECL_USER_DISPATCH 5 -struct ecl_instance { /* instance header */ - _ECL_HDR1(isgf); - cl_index length; /* instance length */ - cl_object clas; /* instance class */ - cl_objectfn entry; /* entry address */ - cl_object sig; /* generation signature */ - cl_object *slots; /* instance slots */ +struct ecl_instance { /* instance header */ + _ECL_HDR1(isgf); + cl_index length; /* instance length */ + cl_object clas; /* instance class */ + cl_objectfn entry; /* entry address */ + cl_object sig; /* generation signature */ + cl_object *slots; /* instance slots */ }; #endif /* CLOS */ #ifdef ECL_SSE2 union ecl_sse_data { - /* This member must be first in order for - ecl_def_ct_sse_pack to work properly. */ - uint8_t b8[16]; - int8_t i8[16]; + /* This member must be first in order for + ecl_def_ct_sse_pack to work properly. */ + uint8_t b8[16]; + int8_t i8[16]; - __m128 vf; - __m128i vi; - __m128d vd; + __m128 vf; + __m128i vi; + __m128d vd; #ifdef ecl_uint16_t - ecl_uint16_t b16[8]; - ecl_int16_t i16[8]; + ecl_uint16_t b16[8]; + ecl_int16_t i16[8]; #endif #ifdef ecl_uint32_t - ecl_uint32_t b32[4]; - ecl_int32_t i32[4]; + ecl_uint32_t b32[4]; + ecl_int32_t i32[4]; #endif #ifdef ecl_uint64_t - ecl_uint64_t b64[2]; - ecl_int64_t i64[2]; + ecl_uint64_t b64[2]; + ecl_int64_t i64[2]; #endif - float sf[4]; - double df[2]; + float sf[4]; + double df[2]; }; struct ecl_sse_pack { - _ECL_HDR1(elttype); - union ecl_sse_data data; + _ECL_HDR1(elttype); + union ecl_sse_data data; }; #endif /* - Definition of lispunion. + Definition of lispunion. */ union cl_lispunion { #ifndef ECL_SMALL_CONS - struct ecl_cons cons; /* unoptimized cons */ + struct ecl_cons cons; /* unoptimized cons */ #endif - struct ecl_bignum big; /* bignum */ - struct ecl_ratio ratio; /* ratio */ - struct ecl_singlefloat SF; /* single floating-point number */ - struct ecl_doublefloat DF; /* double floating-point number */ + struct ecl_bignum big; /* bignum */ + struct ecl_ratio ratio; /* ratio */ + struct ecl_singlefloat SF; /* single floating-point number */ + struct ecl_doublefloat DF; /* double floating-point number */ #ifdef ECL_LONG_FLOAT - struct ecl_long_float longfloat; /* long-float */ + struct ecl_long_float longfloat; /* long-float */ #endif - struct ecl_complex complex; /* complex number */ - struct ecl_symbol symbol; /* symbol */ - struct ecl_package pack; /* package */ - struct ecl_hashtable hash; /* hash table */ - struct ecl_array array; /* array */ - struct ecl_vector vector; /* vector */ - struct ecl_base_string base_string; /* base-string */ + struct ecl_complex complex; /* complex number */ + struct ecl_symbol symbol; /* symbol */ + struct ecl_package pack; /* package */ + struct ecl_hashtable hash; /* hash table */ + struct ecl_array array; /* array */ + struct ecl_vector vector; /* vector */ + struct ecl_base_string base_string; /* base-string */ #ifdef ECL_UNICODE - struct ecl_string string; /* string */ + struct ecl_string string; /* string */ #endif - struct ecl_stream stream; /* stream */ - struct ecl_random random; /* random-states */ - struct ecl_readtable readtable; /* read table */ - struct ecl_pathname pathname; /* path name */ - struct ecl_bytecodes bytecodes; /* bytecompiled function / code */ - struct ecl_bclosure bclosure; /* bytecompiled closure */ - struct ecl_cfun cfun; /* compiled function */ - struct ecl_cfunfixed cfunfixed; /* compiled function */ - struct ecl_cclosure cclosure; /* compiled closure */ + struct ecl_stream stream; /* stream */ + struct ecl_random random; /* random-states */ + struct ecl_readtable readtable; /* read table */ + struct ecl_pathname pathname; /* path name */ + struct ecl_bytecodes bytecodes; /* bytecompiled function / code */ + struct ecl_bclosure bclosure; /* bytecompiled closure */ + struct ecl_cfun cfun; /* compiled function */ + struct ecl_cfunfixed cfunfixed; /* compiled function */ + struct ecl_cclosure cclosure; /* compiled closure */ - struct ecl_dummy d; /* dummy */ + struct ecl_dummy d; /* dummy */ #ifdef CLOS - struct ecl_instance instance; /* clos instance */ + struct ecl_instance instance; /* clos instance */ #else - struct ecl_structure str; /* structure */ + struct ecl_structure str; /* structure */ #endif /* CLOS */ #ifdef ECL_THREADS - struct ecl_process process; /* process */ - struct ecl_queue queue; /* lock */ - struct ecl_lock lock; /* lock */ - struct ecl_rwlock rwlock; /* read/write lock */ + struct ecl_process process; /* process */ + struct ecl_queue queue; /* lock */ + struct ecl_lock lock; /* lock */ + struct ecl_rwlock rwlock; /* read/write lock */ struct ecl_condition_variable condition_variable; /* condition-variable */ - struct ecl_semaphore semaphore; /* semaphore */ - struct ecl_barrier barrier; /* barrier */ - struct ecl_mailbox mailbox; /* mailbox */ + struct ecl_semaphore semaphore; /* semaphore */ + struct ecl_barrier barrier; /* barrier */ + struct ecl_mailbox mailbox; /* mailbox */ #endif - struct ecl_codeblock cblock; /* codeblock */ - struct ecl_foreign foreign; /* user defined data type */ - struct ecl_stack_frame frame; /* stack frame */ - struct ecl_weak_pointer weak; /* weak pointers */ + struct ecl_codeblock cblock; /* codeblock */ + struct ecl_foreign foreign; /* user defined data type */ + struct ecl_stack_frame frame; /* stack frame */ + struct ecl_weak_pointer weak; /* weak pointers */ #ifdef ECL_SSE2 - struct ecl_sse_pack sse; + struct ecl_sse_pack sse; #endif }; /* - Type_of. + Type_of. */ #if defined(__cplusplus) || (defined(__GNUC__) && !defined(__STRICT_ANSI__)) static inline cl_type ecl_t_of(cl_object o) { - int i = ECL_IMMEDIATE(o); - return (i? (cl_type)i : (cl_type)(o->d.t)); + int i = ECL_IMMEDIATE(o); + return (i? (cl_type)i : (cl_type)(o->d.t)); } #else -#define ecl_t_of(o) \ - ((cl_type)(ECL_IMMEDIATE(o) ? ECL_IMMEDIATE(o) : ((o)->d.t))) +#define ecl_t_of(o) \ + ((cl_type)(ECL_IMMEDIATE(o) ? ECL_IMMEDIATE(o) : ((o)->d.t))) #endif #define type_of(o) ecl_t_of(o) /* - This is used to retrieve optional arguments + This is used to retrieve optional arguments */ typedef struct { - va_list args; - cl_object *sp; - int narg; + va_list args; + cl_object *sp; + int narg; } ecl_va_list[1]; #ifdef __cplusplus diff --git a/src/h/page.h b/src/h/page.h index 1620bc589..a5fa9d259 100644 --- a/src/h/page.h +++ b/src/h/page.h @@ -27,11 +27,11 @@ extern "C" { #endif extern struct typemanager { - const char *tm_name; - cl_index tm_size; + const char *tm_name; + cl_index tm_size; } tm_table[(int)t_end]; -#define tm_of(t) (&tm_table[(int)(t)]) +#define tm_of(t) (&tm_table[(int)(t)]) #endif @@ -42,89 +42,89 @@ extern struct typemanager { #if !defined(GBC_BOEHM) /* THREADS: If you make it bigger, the bug is less frequent */ #ifdef SYSV -#define HOLEPAGE 32 +#define HOLEPAGE 32 #else -#define HOLEPAGE 128 +#define HOLEPAGE 128 #endif -#define INIT_HOLEPAGE 150 -#define CBMINSIZE 64 /* contiguous block minimal size */ +#define INIT_HOLEPAGE 150 +#define CBMINSIZE 64 /* contiguous block minimal size */ typedef char *cl_ptr; -#define ptr2int(p) ((cl_ptr)(p) - (cl_ptr)0) -#define int2ptr(n) ((cl_ptr)0 + (n)) -#define page(p) (((cl_ptr)(p) - heap_start)/LISP_PAGESIZE) -#define pagetochar(x) (heap_start + (x) * LISP_PAGESIZE) +#define ptr2int(p) ((cl_ptr)(p) - (cl_ptr)0) +#define int2ptr(n) ((cl_ptr)0 + (n)) +#define page(p) (((cl_ptr)(p) - heap_start)/LISP_PAGESIZE) +#define pagetochar(x) (heap_start + (x) * LISP_PAGESIZE) #define round_to_page(x) (((x) + LISP_PAGESIZE - 1) / LISP_PAGESIZE) -#define round_up(n) (((n) + 03) & ~03) -#define available_pages() ((cl_index)(real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)) +#define round_up(n) (((n) + 03) & ~03) +#define available_pages() ((cl_index)(real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)) extern cl_index real_maxpage; extern cl_index new_holepage; /* - The struct of free lists. + The struct of free lists. */ struct freelist { - HEADER; - cl_object f_link; + HEADER; + cl_object f_link; }; /* - Type map. + Type map. - enum type type_map[MAXPAGE]; + enum type type_map[MAXPAGE]; */ extern char type_map[MAXPAGE]; /* - Storage manager for each type. + Storage manager for each type. */ struct typemanager { - cl_type tm_type; /* type */ - cl_index tm_size; /* element size in bytes */ - cl_index tm_nppage; /* number per page */ - cl_object tm_free; /* free list */ - /* Note that it is of type object. */ - cl_index tm_nfree; /* number of free elements */ - cl_index tm_nused; /* number of elements used */ - cl_index tm_npage; /* number of pages */ - cl_index tm_maxpage; /* maximum number of pages */ - char *tm_name; /* type name */ - cl_index tm_gccount; /* GC count */ + cl_type tm_type; /* type */ + cl_index tm_size; /* element size in bytes */ + cl_index tm_nppage; /* number per page */ + cl_object tm_free; /* free list */ + /* Note that it is of type object. */ + cl_index tm_nfree; /* number of free elements */ + cl_index tm_nused; /* number of elements used */ + cl_index tm_npage; /* number of pages */ + cl_index tm_maxpage; /* maximum number of pages */ + char *tm_name; /* type name */ + cl_index tm_gccount; /* GC count */ }; /* - The table of type managers. + The table of type managers. */ extern struct typemanager tm_table[(int)t_end]; -#define tm_of(t) (&(tm_table[(int)tm_table[(int)(t)].tm_type])) +#define tm_of(t) (&(tm_table[(int)tm_table[(int)(t)].tm_type])) /* - Contiguous block header. + Contiguous block header. */ -struct contblock { /* contiguous block header */ - cl_index cb_size; /* size in bytes */ - struct contblock *cb_link; /* contiguous block link */ +struct contblock { /* contiguous block header */ + cl_index cb_size; /* size in bytes */ + struct contblock *cb_link; /* contiguous block link */ }; /* - The pointer to the contiguous blocks. + The pointer to the contiguous blocks. */ -extern struct contblock *cb_pointer; /* contblock pointer */ +extern struct contblock *cb_pointer; /* contblock pointer */ /* - Variables for memory management. + Variables for memory management. */ -extern cl_index ncb; /* number of contblocks */ -extern cl_index ncbpage; /* number of contblock pages */ -extern cl_index maxcbpage; /* maximum number of contblock pages */ -extern cl_index cbgccount; /* contblock gc count */ -extern cl_index holepage; /* hole pages */ +extern cl_index ncb; /* number of contblocks */ +extern cl_index ncbpage; /* number of contblock pages */ +extern cl_index maxcbpage; /* maximum number of contblock pages */ +extern cl_index cbgccount; /* contblock gc count */ +extern cl_index holepage; /* hole pages */ -extern char *heap_start; /* heap start */ -extern char *heap_end; /* heap end */ -extern char *data_end; /* core end */ +extern char *heap_start; /* heap start */ +extern char *heap_end; /* heap end */ +extern char *data_end; /* core end */ #endif /* !GBC_BOEHM */ diff --git a/src/h/stacks.h b/src/h/stacks.h index 5a725951d..44e523502 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -36,12 +36,12 @@ extern "C" { **************/ typedef struct ecl_bds_frame { - cl_object symbol; /* symbol */ - cl_object value; /* previous value of the symbol */ + cl_object symbol; /* symbol */ + cl_object value; /* previous value of the symbol */ } *ecl_bds_ptr; -#define ecl_bds_check(env) \ - (ecl_unlikely(env->bds_top >= env->bds_limit)? (ecl_bds_overflow(),1) : 0) +#define ecl_bds_check(env) \ + (ecl_unlikely(env->bds_top >= env->bds_limit)? (ecl_bds_overflow(),1) : 0) #define ECL_MISSING_SPECIAL_BINDING (~((cl_index)0)) @@ -84,8 +84,8 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) slot = ++env->bds_top; if (slot >= env->bds_limit) slot = ecl_bds_overflow(); slot->symbol = s; - slot->value = s->symbol.value; - s->symbol.value = v; + slot->value = s->symbol.value; + s->symbol.value = v; # endif /* !ECL_THREADS */ } @@ -109,14 +109,14 @@ static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) slot = ++env->bds_top; if (slot >= env->bds_limit) slot = ecl_bds_overflow(); slot->symbol = s; - slot->value = s->symbol.value; + slot->value = s->symbol.value; # endif /* !ECL_THREADS */ } static inline void ecl_bds_unwind1_inl(cl_env_ptr env) { - ecl_bds_ptr slot = env->bds_top--; - cl_object s = slot->symbol; + ecl_bds_ptr slot = env->bds_top--; + cl_object s = slot->symbol; # ifdef ECL_THREADS cl_object *location = env->thread_local_bindings + s->symbol.binding; *location = slot->value; @@ -142,7 +142,7 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) cl_object *location = env->thread_local_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } - return &s->symbol.value; + return &s->symbol.value; } # define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v)) # define ecl_bds_read ecl_bds_read_inl @@ -152,26 +152,26 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) # define ecl_bds_unwind1 ecl_bds_unwind1_inl #else /* !__GNUC__ */ # ifndef ECL_THREADS -# define ecl_bds_bind(env,sym,val) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = (val); \ - ecl_bds_check(env_copy); \ - (++(env_copy->bds_top))->symbol = s, \ - env_copy->bds_top->value = s->symbol.value; \ - s->symbol.value = v; } while (0) -# define ecl_bds_push(env,sym) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = s->symbol.value; \ - ecl_bds_check(env_copy); \ - (++(env_copy->bds_top))->symbol = s, \ - env_copy->bds_top->value = s->symbol.value; } while (0); -# define ecl_bds_unwind1(env) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = env_copy->bds_top->symbol; \ - s->symbol.value = env_copy->bds_top->value; \ - --(env_copy->bds_top); } while (0) +# define ecl_bds_bind(env,sym,val) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = (sym); \ + const cl_object v = (val); \ + ecl_bds_check(env_copy); \ + (++(env_copy->bds_top))->symbol = s, \ + env_copy->bds_top->value = s->symbol.value; \ + s->symbol.value = v; } while (0) +# define ecl_bds_push(env,sym) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = (sym); \ + const cl_object v = s->symbol.value; \ + ecl_bds_check(env_copy); \ + (++(env_copy->bds_top))->symbol = s, \ + env_copy->bds_top->value = s->symbol.value; } while (0); +# define ecl_bds_unwind1(env) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = env_copy->bds_top->symbol; \ + s->symbol.value = env_copy->bds_top->value; \ + --(env_copy->bds_top); } while (0) # endif /* !ECL_THREADS */ #endif /* !__GNUC__ */ @@ -180,28 +180,28 @@ static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) ****************************/ typedef struct ecl_ihs_frame { - struct ecl_ihs_frame *next; - cl_object function; - cl_object lex_env; - cl_index index; + struct ecl_ihs_frame *next; + cl_object function; + cl_object lex_env; + cl_index index; cl_index bds; } *ecl_ihs_ptr; #define ecl_ihs_push(env,rec,fun,lisp_env) do { \ - const cl_env_ptr __the_env = (env); \ - ecl_ihs_ptr const r = (rec); \ - r->next=__the_env->ihs_top; \ - r->function=(fun); \ - r->lex_env=(lisp_env); \ - r->index=__the_env->ihs_top->index+1; \ + const cl_env_ptr __the_env = (env); \ + ecl_ihs_ptr const r = (rec); \ + r->next=__the_env->ihs_top; \ + r->function=(fun); \ + r->lex_env=(lisp_env); \ + r->index=__the_env->ihs_top->index+1; \ r->bds=__the_env->bds_top - __the_env->bds_org; \ - __the_env->ihs_top = r; \ + __the_env->ihs_top = r; \ } while(0) -#define ecl_ihs_pop(env) do { \ - const cl_env_ptr __the_env = (env); \ - ecl_ihs_ptr r = __the_env->ihs_top; \ - if (r) __the_env->ihs_top = r->next; \ +#define ecl_ihs_pop(env) do { \ + const cl_env_ptr __the_env = (env); \ + ecl_ihs_ptr r = __the_env->ihs_top; \ + if (r) __the_env->ihs_top = r->next; \ } while(0) /*************** @@ -228,11 +228,11 @@ typedef struct ecl_ihs_frame { */ typedef struct ecl_frame { - jmp_buf frs_jmpbuf; - cl_object frs_val; - cl_index frs_bds_top_index; - ecl_ihs_ptr frs_ihs; - cl_index frs_sp; + jmp_buf frs_jmpbuf; + cl_object frs_val; + cl_index frs_bds_top_index; + ecl_ihs_ptr frs_ihs; + cl_index frs_sp; } *ecl_frame_ptr; extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_object); @@ -264,18 +264,18 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje */ #define ecl_va_start(a,p,n,k) { \ - a[0].narg = (n)-(k); \ - va_start(a[0].args,p); \ - a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(a[0].narg); } + a[0].narg = (n)-(k); \ + va_start(a[0].args,p); \ + a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(a[0].narg); } #define ecl_va_arg(a) \ - (a[0].narg--,(a[0].sp? *(a[0].sp++) : va_arg(a[0].args,cl_object))) + (a[0].narg--,(a[0].sp? *(a[0].sp++) : va_arg(a[0].args,cl_object))) #define ecl_va_copy(dest,orig) { \ - dest[0].narg = orig[0].narg; \ - dest[0].sp = orig[0].sp; \ - va_copy(dest[0].args,orig[0].args); \ + dest[0].narg = orig[0].narg; \ + dest[0].sp = orig[0].sp; \ + va_copy(dest[0].args,orig[0].args); \ } #define ecl_va_end(a) \ - va_end(a[0].args) + va_end(a[0].args) /*********************** * RETURN VALUES STACK @@ -284,24 +284,24 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje #define ecl_nth_value(env,n) ((env)->values[n]) #define ecl_nvalues(env) ((env)->nvalues) #define ecl_return0(env) \ - do { (env)->nvalues = 0; return ECL_NIL; } while (0) + do { (env)->nvalues = 0; return ECL_NIL; } while (0) #define ecl_return1(env,x) \ - do { (env)->nvalues = 1; return (x); } while (0) -#define ecl_return2(env,x,y) \ - do { \ - cl_env_ptr __ecl_env = (env); \ - cl_object __aux1 = (x), __aux2=(y); \ - __ecl_env->values[1] = __aux2; \ - __ecl_env->nvalues = 2; return __aux1; \ - } while (0) -#define ecl_return3(env,x,y,z) \ - do { \ - cl_env_ptr __ecl_env = (env); \ - cl_object __aux1=(x), __aux2=(y), __aux3=(z); \ - __ecl_env->values[1] = __aux2; \ - __ecl_env->values[2] = __aux3; \ - __ecl_env->nvalues = 3; return __aux1; \ - } while (0) + do { (env)->nvalues = 1; return (x); } while (0) +#define ecl_return2(env,x,y) \ + do { \ + cl_env_ptr __ecl_env = (env); \ + cl_object __aux1 = (x), __aux2=(y); \ + __ecl_env->values[1] = __aux2; \ + __ecl_env->nvalues = 2; return __aux1; \ + } while (0) +#define ecl_return3(env,x,y,z) \ + do { \ + cl_env_ptr __ecl_env = (env); \ + cl_object __aux1=(x), __aux2=(y), __aux3=(z); \ + __ecl_env->values[1] = __aux2; \ + __ecl_env->values[2] = __aux3; \ + __ecl_env->nvalues = 3; return __aux1; \ + } while (0) /***************************** * LEXICAL ENVIRONMENT STACK @@ -311,13 +311,13 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje * a variable definition, a tagbody or block tag, or a local function * definition. * - * lex_env ---> ( { record }* ) - * record = variable | function | block_tag | tagbody_tag + * lex_env ---> ( { record }* ) + * record = variable | function | block_tag | tagbody_tag * - * variable = ( var_name[symbol] . value ) - * function = ( function[bytecodes] . fun_name[symbol] ) - * block_tag = ( tag[fixnum] . block_name[symbol] ) - * tagbody_tag = ( tag[fixnum] . 0 ) + * variable = ( var_name[symbol] . value ) + * function = ( function[bytecodes] . fun_name[symbol] ) + * block_tag = ( tag[fixnum] . block_name[symbol] ) + * tagbody_tag = ( tag[fixnum] . 0 ) */ /************* @@ -379,92 +379,92 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje * HIGH LEVEL CONTROL STRUCTURES * *********************************/ -#define ECL_UNWIND_PROTECT_BEGIN(the_env) do { \ - bool __unwinding; ecl_frame_ptr __next_fr; \ - const cl_env_ptr __the_env = (the_env); \ - cl_index __nr; \ - if (ecl_frs_push(__the_env,ECL_PROTECT_TAG)) { \ - __unwinding=1; __next_fr=__the_env->nlj_fr; \ - } else { +#define ECL_UNWIND_PROTECT_BEGIN(the_env) do { \ + bool __unwinding; ecl_frame_ptr __next_fr; \ + const cl_env_ptr __the_env = (the_env); \ + cl_index __nr; \ + if (ecl_frs_push(__the_env,ECL_PROTECT_TAG)) { \ + __unwinding=1; __next_fr=__the_env->nlj_fr; \ + } else { #define ECL_UNWIND_PROTECT_EXIT \ - __unwinding=0; } \ - ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __unwinding=0; } \ + ecl_frs_pop(__the_env); \ + __nr = ecl_stack_push_values(__the_env); #define ECL_UNWIND_PROTECT_END \ - ecl_stack_pop_values(__the_env,__nr); \ - if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) + ecl_stack_pop_values(__the_env,__nr); \ + if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) #define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frame_id++) -#define ECL_BLOCK_BEGIN(the_env,id) do { \ - const cl_object __id = ECL_NEW_FRAME_ID(the_env); \ - const cl_env_ptr __the_env = (the_env); \ - if (ecl_frs_push(__the_env,__id) == 0) +#define ECL_BLOCK_BEGIN(the_env,id) do { \ + const cl_object __id = ECL_NEW_FRAME_ID(the_env); \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,__id) == 0) #define ECL_BLOCK_END \ - ecl_frs_pop(__the_env); } while(0) + ecl_frs_pop(__the_env); } while(0) -#define ECL_CATCH_BEGIN(the_env,tag) do { \ - const cl_env_ptr __the_env = (the_env); \ - if (ecl_frs_push(__the_env,tag) == 0) { +#define ECL_CATCH_BEGIN(the_env,tag) do { \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,tag) == 0) { #define ECL_CATCH_END } \ - ecl_frs_pop(__the_env); } while (0) + ecl_frs_pop(__the_env); } while (0) -#define ECL_RESTART_CASE_BEGIN(the_env, names) do { \ - const cl_env_ptr __the_env = (the_env); \ - const cl_object __ecl_tag = ecl_list1(names); \ - ecl_bds_bind(__the_env, ECL_RESTART_CLUSTERS, \ - si_bind_simple_restarts(__ecl_tag, names)); \ - if (ecl_frs_push(__the_env,__ecl_tag) == 0) { +#define ECL_RESTART_CASE_BEGIN(the_env, names) do { \ + const cl_env_ptr __the_env = (the_env); \ + const cl_object __ecl_tag = ecl_list1(names); \ + ecl_bds_bind(__the_env, ECL_RESTART_CLUSTERS, \ + si_bind_simple_restarts(__ecl_tag, names)); \ + if (ecl_frs_push(__the_env,__ecl_tag) == 0) { -#define ECL_RESTART_CASE(code, args) \ - } else if (__the_env->values[1] == ecl_make_fixnum(code)) { \ - const cl_object args = __the_env->values[0]; - +#define ECL_RESTART_CASE(code, args) \ + } else if (__the_env->values[1] == ecl_make_fixnum(code)) { \ + const cl_object args = __the_env->values[0]; + -#define ECL_RESTART_CASE_END } \ - ecl_frs_pop(__the_env); \ - ecl_bds_unwind1(__the_env); \ - } while (0) +#define ECL_RESTART_CASE_END } \ + ecl_frs_pop(__the_env); \ + ecl_bds_unwind1(__the_env); \ + } while (0) -#define ECL_HANDLER_CASE_BEGIN(the_env, names) do { \ - const cl_env_ptr __the_env = (the_env); \ - const cl_object __ecl_tag = ecl_list1(names); \ - ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \ - si_bind_simple_handlers(__ecl_tag, names)); \ - if (ecl_frs_push(__the_env,__ecl_tag) == 0) { +#define ECL_HANDLER_CASE_BEGIN(the_env, names) do { \ + const cl_env_ptr __the_env = (the_env); \ + const cl_object __ecl_tag = ecl_list1(names); \ + ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \ + si_bind_simple_handlers(__ecl_tag, names)); \ + if (ecl_frs_push(__the_env,__ecl_tag) == 0) { -#define ECL_HANDLER_CASE(code, args) \ - } else if (__the_env->values[1] == ecl_make_fixnum(code)) { \ - const cl_object args = __the_env->values[0]; - +#define ECL_HANDLER_CASE(code, args) \ + } else if (__the_env->values[1] == ecl_make_fixnum(code)) { \ + const cl_object args = __the_env->values[0]; + -#define ECL_HANDLER_CASE_END } \ - ecl_frs_pop(__the_env); \ - ecl_bds_unwind1(__the_env); \ - } while (0) +#define ECL_HANDLER_CASE_END } \ + ecl_frs_pop(__the_env); \ + ecl_bds_unwind1(__the_env); \ + } while (0) #if defined(_MSC_VER) -# define ECL_CATCH_ALL_BEGIN(the_env) do { \ - const cl_env_ptr __the_env = (the_env); \ - _try { \ - const cl_env_ptr __the_env = (the_env); \ - if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) { +# define ECL_CATCH_ALL_BEGIN(the_env) do { \ + const cl_env_ptr __the_env = (the_env); \ + _try { \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) { # define ECL_CATCH_ALL_IF_CAUGHT } else { -# define ECL_CATCH_ALL_END }} \ - _except(_ecl_w32_exception_filter(GetExceptionInformation())) \ - { (void)0; } \ - ecl_frs_pop(__the_env); } while(0) +# define ECL_CATCH_ALL_END }} \ + _except(_ecl_w32_exception_filter(GetExceptionInformation())) \ + { (void)0; } \ + ecl_frs_pop(__the_env); } while(0) #else -# define ECL_CATCH_ALL_BEGIN(the_env) do { \ - const cl_env_ptr __the_env = (the_env); \ - if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) { +# define ECL_CATCH_ALL_BEGIN(the_env) do { \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) { # define ECL_CATCH_ALL_IF_CAUGHT } else { # define ECL_CATCH_ALL_END } \ - ecl_frs_pop(__the_env); } while(0) + ecl_frs_pop(__the_env); } while(0) #endif diff --git a/src/h/unify.h b/src/h/unify.h index 1cc0ce96b..af4002c90 100644 --- a/src/h/unify.h +++ b/src/h/unify.h @@ -15,19 +15,19 @@ */ -#define trail_push(loc) (*trail_top++ = (loc)) -#define trail_pop (**--trail_top = OBJNULL) -#define trail_mark trail_push((object *)NULL) -#define trail_restore {while (trail_top[-1] != (object *)NULL) \ - trail_pop;} -#define trail_unmark {trail_restore; trail_top--;} -#define BIND(loc, val) {loc = val; trail_push(&loc);} +#define trail_push(loc) (*trail_top++ = (loc)) +#define trail_pop (**--trail_top = OBJNULL) +#define trail_mark trail_push((object *)NULL) +#define trail_restore {while (trail_top[-1] != (object *)NULL) \ + trail_pop;} +#define trail_unmark {trail_restore; trail_top--;} +#define BIND(loc, val) {loc = val; trail_push(&loc);} -#define get_value(v, x) unify(x, v) -#define get_constant(c, x) (c == x || unify(x, c)) -#define get_nil(x) (ECL_NIL == x || unify(x, ECL_NIL)) +#define get_value(v, x) unify(x, v) +#define get_constant(c, x) (c == x || unify(x, c)) +#define get_nil(x) (ECL_NIL == x || unify(x, ECL_NIL)) -#define unify_slot (*slotf)(*slot) -#define unify_value(loc) (*slotf)(loc) -#define unify_constant(c) (*slotf)(c) -#define unify_nil (*slotf)(ECL_NIL) +#define unify_slot (*slotf)(*slot) +#define unify_value(loc) (*slotf)(loc) +#define unify_constant(c) (*slotf)(c) +#define unify_nil (*slotf)(ECL_NIL) diff --git a/src/lsp/arraylib.lsp b/src/lsp/arraylib.lsp index 1e65f595b..a0c100a45 100644 --- a/src/lsp/arraylib.lsp +++ b/src/lsp/arraylib.lsp @@ -18,14 +18,14 @@ (in-package "SYSTEM") (defun make-array (dimensions - &key (element-type t) - (initial-element nil initial-element-supplied-p) - (initial-contents nil initial-contents-supplied-p) - adjustable fill-pointer - displaced-to (displaced-index-offset 0)) + &key (element-type t) + (initial-element nil initial-element-supplied-p) + (initial-contents nil initial-contents-supplied-p) + adjustable fill-pointer + displaced-to (displaced-index-offset 0)) "Args: (dimensions &key (element-type t) initial-element (initial-contents nil) - (adjustable nil) (fill-pointer nil) (displaced-to nil) - (displaced-index-offset 0) (static nil)) + (adjustable nil) (fill-pointer nil) (displaced-to nil) + (displaced-index-offset 0) (static nil)) Creates an array of the specified DIMENSIONS. DIMENSIONS is a list of non-negative integers each representing the length of the corresponding dimension. It may be an integer for vectors, i.e., one-dimensional arrays. @@ -45,7 +45,7 @@ OFFSET)th element of the given array.If the STATIC argument is supplied with a non-nil value, then the body of the array is allocated as a contiguous block." (let ((x (sys:make-pure-array element-type dimensions adjustable - fill-pointer displaced-to displaced-index-offset))) + fill-pointer displaced-to displaced-index-offset))) (declare (array x)) (cond (initial-element-supplied-p (when initial-contents-supplied-p @@ -60,29 +60,29 @@ contiguous block." (declare (array array) (sequence initial-contents) (optimize (safety 0)) - (si::c-local)) + (si::c-local)) (labels ((iterate-over-contents (array contents dims written) - (declare (fixnum written) - (array array) - (optimize (safety 0))) - (when (/= (length contents) (first dims)) - (error "In MAKE-ARRAY: the elements in :INITIAL-CONTENTS do not match the array dimensions")) - (if (= (length dims) 1) - (do* ((it (make-seq-iterator contents) (seq-iterator-next contents it))) - ((null it)) - (sys:row-major-aset array written (seq-iterator-ref contents it)) - (incf written)) - (do* ((it (make-seq-iterator contents) (seq-iterator-next contents it))) - ((null it)) - (setf written (iterate-over-contents array - (seq-iterator-ref contents it) - (rest dims) - written)))) - written)) + (declare (fixnum written) + (array array) + (optimize (safety 0))) + (when (/= (length contents) (first dims)) + (error "In MAKE-ARRAY: the elements in :INITIAL-CONTENTS do not match the array dimensions")) + (if (= (length dims) 1) + (do* ((it (make-seq-iterator contents) (seq-iterator-next contents it))) + ((null it)) + (sys:row-major-aset array written (seq-iterator-ref contents it)) + (incf written)) + (do* ((it (make-seq-iterator contents) (seq-iterator-next contents it))) + ((null it)) + (setf written (iterate-over-contents array + (seq-iterator-ref contents it) + (rest dims) + written)))) + written)) (let ((dims (array-dimensions array))) (if dims - (iterate-over-contents array initial-contents dims 0) - (setf (aref array) initial-contents)))) + (iterate-over-contents array initial-contents dims 0) + (setf (aref array) initial-contents)))) array) @@ -100,7 +100,7 @@ Returns a list whose N-th element is the length of the N-th dimension of ARRAY." (d nil)) ((= i 0) d) (declare (fixnum i) - (optimize (safety 0))) + (optimize (safety 0))) (push (array-dimension array (decf i)) d))) @@ -109,23 +109,23 @@ Returns a list whose N-th element is the length of the N-th dimension of ARRAY." Returns T if INDEXes are valid indexes of ARRAY; NIL otherwise. The number of INDEXes must be equal to the rank of ARRAY." (declare (type array array) - (optimize (safety 0)) + (optimize (safety 0)) (ext:check-arguments-type)) (do* ((indices indices (cons-cdr indices)) - (r (array-rank array)) - (i 0 (1+ i))) + (r (array-rank array)) + (i 0 (1+ i))) ((>= i r) t) (declare (type index r i)) (if indices - (let* ((index (cons-car indices))) - (when (or (not (si::fixnump index)) - (minusp (truly-the fixnum index)) - (>= (truly-the fixnum index) (array-dimension array i))) - (return nil))) - (error "The rank of the array is ~R,~%~ + (let* ((index (cons-car indices))) + (when (or (not (si::fixnump index)) + (minusp (truly-the fixnum index)) + (>= (truly-the fixnum index) (array-dimension array i))) + (return nil))) + (error "The rank of the array is ~R,~%~ ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~ supplied." - r i)))) + r i)))) (defun row-major-index-inner (array indices) (declare (optimize (safety 0)) @@ -286,42 +286,42 @@ pointer is 0 already." (defun copy-array-contents (dest orig) (declare (si::c-local) (array dest orig) - (optimize (safety 0))) + (optimize (safety 0))) (labels ((do-copy (dest orig dims1 dims2 start1 start2) - (declare (array dest orig) - (list dims1 dims2) - (ext:array-index start1 start2)) - (let* ((d1 (pop dims1)) - (d2 (pop dims2)) - (l (min d1 d2)) - (i1 start1) - (i2 start2)) - (declare (ext:array-index d1 d2 l i1 i2)) - (if (null dims1) - (copy-subarray dest i1 orig i2 l) - (let ((step1 (apply #'* dims1)) - (step2 (apply #'* dims2))) - (declare (ext:array-index step1 step2)) - (dotimes (i l) - (declare (ext:array-index i)) - (do-copy dest orig dims1 dims2 i1 i2) - (incf i1 step1) - (incf i2 step2))))))) + (declare (array dest orig) + (list dims1 dims2) + (ext:array-index start1 start2)) + (let* ((d1 (pop dims1)) + (d2 (pop dims2)) + (l (min d1 d2)) + (i1 start1) + (i2 start2)) + (declare (ext:array-index d1 d2 l i1 i2)) + (if (null dims1) + (copy-subarray dest i1 orig i2 l) + (let ((step1 (apply #'* dims1)) + (step2 (apply #'* dims2))) + (declare (ext:array-index step1 step2)) + (dotimes (i l) + (declare (ext:array-index i)) + (do-copy dest orig dims1 dims2 i1 i2) + (incf i1 step1) + (incf i2 step2))))))) ;; We have to lie to DO-COPY reshaping the zero-dimensional array ;; as a one-dimensional array of one element. (do-copy dest orig (or (array-dimensions dest) '(1)) - (or (array-dimensions orig) '(1)) - 0 0))) + (or (array-dimensions orig) '(1)) + 0 0))) (defun adjust-array (array new-dimensions &rest r - &key (element-type (array-element-type array)) - initial-element - initial-contents - fill-pointer - displaced-to - displaced-index-offset) + &key (element-type (array-element-type array)) + initial-element + initial-contents + fill-pointer + displaced-to + displaced-index-offset) "Args: (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) @@ -336,12 +336,12 @@ adjustable array." ;; Cannot set a fill pointer for an array that does not have any. (if (array-has-fill-pointer-p array) (unless fill-pointer - (setf r (list* :fill-pointer (fill-pointer array) r))) + (setf r (list* :fill-pointer (fill-pointer array) r))) (when fill-pointer - (error 'simple-type-error - :datum array - :expected-type '(satisfies array-has-fill-pointer-p) - :format-control "You supplied a fill pointer for an array without it."))) + (error 'simple-type-error + :datum array + :expected-type '(satisfies array-has-fill-pointer-p) + :format-control "You supplied a fill pointer for an array without it."))) (let ((x (apply #'make-array new-dimensions :adjustable t :element-type element-type r))) (declare (array x)) (unless (or displaced-to initial-contents) @@ -353,13 +353,13 @@ adjustable array." (defun shrink-vector (vec len) "Shrinks a vector." (cond ((adjustable-array-p vec) - (adjust-array vec len)) - ((typep vec 'simple-array) - (let ((new-vec (make-array len :element-type (array-element-type vec)))) - (copy-subarray new-vec 0 vec 0 len))) - ((typep vec 'vector) - (setf (fill-pointer vec) len) - vec) - (t - (error "Unable to shrink vector ~S which is type-of ~S" vec (type-of vec))) - )) + (adjust-array vec len)) + ((typep vec 'simple-array) + (let ((new-vec (make-array len :element-type (array-element-type vec)))) + (copy-subarray new-vec 0 vec 0 len))) + ((typep vec 'vector) + (setf (fill-pointer vec) len) + vec) + (t + (error "Unable to shrink vector ~S which is type-of ~S" vec (type-of vec))) + )) diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp index 67384bfa0..05bab32a2 100644 --- a/src/lsp/assert.lsp +++ b/src/lsp/assert.lsp @@ -22,22 +22,22 @@ (declare (c::policy-debug-ihs-frame)) (tagbody again (restart-case - (error 'simple-type-error - :format-control + (error 'simple-type-error + :format-control "In ~:[an anonymous function~;~:*function ~A~], ~ ~:[found object~;~:*the value of ~A is~]~%~8t~S~%~ which is not of expected type ~A" - :format-arguments (list function place object type) - :datum object - :expected-type type - ) + :format-arguments (list function place object type) + :datum object + :expected-type type + ) (use-value (value) - :report (lambda (stream) - (format stream "Supply a new value of type ~A." type)) - :interactive read-evaluated-form - (setf object value) - (unless (typep object type) - (go again))))) + :report (lambda (stream) + (format stream "Supply a new value of type ~A." type)) + :interactive read-evaluated-form + (setf object value) + (unless (typep object type) + (go again))))) object) (defmacro check-type (place type &optional type-string) @@ -51,24 +51,24 @@ value is used to indicate the expected type in the error message." `(let ((,aux ,place)) (declare (:read-only ,aux)) (unless (typep ,aux ',type) - (setf ,place (do-check-type ,aux ',type ',type-string ',place))) + (setf ,place (do-check-type ,aux ',type ',type-string ',place))) nil))) (defun do-check-type (value type type-string place) (tagbody again (unless (typep value type) (restart-case - (error 'simple-type-error - :datum value - :expected-type type - :format-control "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]." - :format-arguments (list place value type-string type)) - (store-value (new-value) - :report (lambda (stream) - (format stream "Supply a new value of ~S" place)) - :interactive read-evaluated-form - (setf value new-value) - (go again))))) + (error 'simple-type-error + :datum value + :expected-type type + :format-control "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]." + :format-arguments (list place value type-string type)) + (store-value (new-value) + :report (lambda (stream) + (format stream "Supply a new value of ~S" place)) + :interactive read-evaluated-form + (setf value new-value) + (go again))))) value) (defmacro assert (test-form &optional places &rest arguments) @@ -95,14 +95,14 @@ for the error message and ARGs are arguments to the format string." ((null c) (nreverse l)) (let ((keys (caar c))) (cond ((atom keys) (unless (null keys) (push keys l))) - (list-is-atom-p (push keys l)) - (t (setq l (append keys l))))))) + (list-is-atom-p (push keys l)) + (t (setq l (append keys l))))))) (defun ecase-error (value values) (error 'CASE-FAILURE :name 'ECASE - :datum value - :expected-type (cons 'MEMBER values) - :possibilities values)) + :datum value + :expected-type (cons 'MEMBER values) + :possibilities values)) (defmacro ecase (keyform &rest clauses) "Syntax: (ecase keyform {({key | ({key}*)} {form}*)}*) @@ -114,28 +114,28 @@ signals an error." (let ((key (gensym))) `(let ((,key ,keyform)) (case ,key ,@clauses - (t (si::ecase-error ,key ',(accumulate-cases clauses nil))))))) + (t (si::ecase-error ,key ',(accumulate-cases clauses nil))))))) (defun ccase-error (keyform key values) (restart-case (error 'CASE-FAILURE - :name 'CCASE - :datum key - :expected-type (cons 'MEMBER values) - :possibilities values) + :name 'CCASE + :datum key + :expected-type (cons 'MEMBER values) + :possibilities values) (store-value (value) :REPORT (lambda (stream) - (format stream "Supply a new value of ~S" keyform)) + (format stream "Supply a new value of ~S" keyform)) :INTERACTIVE read-evaluated-form (return-from ccase-error value)))) (defun remove-otherwise-from-clauses (clauses) (declare (si::c-local)) (mapcar #'(lambda (clause) - (let ((options (first clause))) - (if (member options '(t otherwise)) - (cons (list options) (rest clause)) - clause))) - clauses)) + (let ((options (first clause))) + (if (member options '(t otherwise)) + (cons (list options) (rest clause)) + clause))) + clauses)) (defmacro ccase (keyplace &rest clauses) "Syntax: (ccase place {({key | ({key}*)} {form}*)}*) @@ -146,18 +146,18 @@ continuable error. Before continuing, receives a new value of PLACE from user and searches a KEY again. Repeats this process until the value of PLACE becomes EQL to one of the KEYs." (let* ((key (gensym)) - (repeat (gensym)) - (block (gensym))) + (repeat (gensym)) + (block (gensym))) (setq clauses (remove-otherwise-from-clauses clauses)) `(block ,block (tagbody ,repeat - (let ((,key ,keyplace)) - (return-from ,block - (case ,key ,@clauses - (t (setf ,keyplace - (si::ccase-error ',keyplace ,key - ',(accumulate-cases clauses nil))) - (go ,repeat))))))))) + (let ((,key ,keyplace)) + (return-from ,block + (case ,key ,@clauses + (t (setf ,keyplace + (si::ccase-error ',keyplace ,key + ',(accumulate-cases clauses nil))) + (go ,repeat))))))))) (defmacro typecase (keyform &rest clauses) "Syntax: (typecase keyform {(type {form}*)}*) @@ -178,9 +178,9 @@ be used as a TYPE to specify the default case." (defun etypecase-error (value types) (error 'CASE-FAILURE :name 'ETYPECASE - :datum value - :expected-type (cons 'OR types) - :possibilities types)) + :datum value + :expected-type (cons 'OR types) + :possibilities types)) (defmacro etypecase (keyform &rest clauses &aux (key (gensym))) "Syntax: (etypecase keyform {(type {form}*)}*) @@ -188,7 +188,7 @@ Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs. If found, then evaluates FORMs that follow the TYPE and returns all values of the last FORM. If not, signals an error." (setq clauses (remove-otherwise-from-clauses clauses)) - (do ((l (reverse clauses) (cdr l)) ; Beppe + (do ((l (reverse clauses) (cdr l)) ; Beppe (form `(etypecase-error ,key ',(accumulate-cases clauses t)))) ((endp l) `(let ((,key ,keyform)) ,form)) (setq form `(if (typep ,key ',(caar l)) @@ -199,13 +199,13 @@ the last FORM. If not, signals an error." (defun ctypecase-error (keyplace value types) (restart-case (error 'CASE-FAILURE - :name 'CTYPECASE - :datum value - :expected-type (cons 'OR types) - :possibilities types) + :name 'CTYPECASE + :datum value + :expected-type (cons 'OR types) + :possibilities types) (store-value (value) :REPORT (lambda (stream) - (format stream "Supply a new value of ~S." keyplace)) + (format stream "Supply a new value of ~S." keyplace)) :INTERACTIVE read-evaluated-form (return-from ctypecase-error value)))) @@ -220,8 +220,8 @@ Repeats this process until the value of PLACE becomes of one of the TYPEs." `(loop (let ((,key ,keyplace)) ,@(mapcar #'(lambda (l) - `(when (typep ,key ',(car l)) - (return (progn ,@(cdr l))))) - clauses) + `(when (typep ,key ',(car l)) + (return (progn ,@(cdr l))))) + clauses) (setf ,keyplace (ctypecase-error ',keyplace ,key - ',(accumulate-cases clauses t)))))) + ',(accumulate-cases clauses t)))))) diff --git a/src/lsp/autoload.lsp b/src/lsp/autoload.lsp index f43cb709d..3d286604a 100644 --- a/src/lsp/autoload.lsp +++ b/src/lsp/autoload.lsp @@ -28,8 +28,8 @@ Returns the string \"ECL\"." (dolist (fname function-names) (let ((thename fname)) (fset fname #'(lambda (&rest args) - (load pathname) - (apply thename args)))))) + (load pathname) + (apply thename args)))))) (unless (fboundp 'compile) (defun proclaim (d) @@ -56,22 +56,22 @@ Report for details." (defun room (&optional x) "Args: (&optional (x t)) Displays information about storage allocation in the following format. - * for each type class - * number of pages so-far allocated for the type class - * maximum number of pages for the type class - * percentage of used cells to cells so-far allocated - * number of times the garbage collector has been called to - collect cells of the type class - * implementation types that belongs to the type class - * number of pages actually allocated for contiguous blocks - * maximum number of pages for contiguous blocks - * number of times the garbage collector has been called to collect - contiguous blocks - * number of pages in the hole - * total number of pages allocated for cells - * total number of pages allocated - * number of available pages - * number of pages ECL can use. + * for each type class + * number of pages so-far allocated for the type class + * maximum number of pages for the type class + * percentage of used cells to cells so-far allocated + * number of times the garbage collector has been called to + collect cells of the type class + * implementation types that belongs to the type class + * number of pages actually allocated for contiguous blocks + * maximum number of pages for contiguous blocks + * number of times the garbage collector has been called to collect + contiguous blocks + * number of pages in the hole + * total number of pages allocated for cells + * total number of pages allocated + * number of available pages + * number of pages ECL can use. The number of times the garbage collector has been called is not shown, if the number is zero. The optional X is simply ignored." (declare (ignorable x)) @@ -86,60 +86,60 @@ in Windows) to learn this.") #-boehm-gc (let* (npage info-list link-alist) (multiple-value-bind - (maxpage leftpage ncbpage maxcbpage ncb cbgbccount - holepage l) - (sys::room-report) + (maxpage leftpage ncbpage maxcbpage ncb cbgbccount + holepage l) + (sys::room-report) (do ((l l (nthcdr 5 l)) - (type-list '(cons - ;; fixnum Beppe - fixnum char - bignum ratio short-float long-float complex - symbol package hash-table - array vector string bit-vector - stream random-state readtable pathname - bytecodes cfun cclosure - #-clos structure #+clos instance #+clos generic-function - #+threads mp::process #+threads mp::lock - si::foreign)) - (tl type-list (cdr tl)) - (i 0 (+ i (if (nth 2 l) (nth 2 l) 0)))) - ((null l) (setq npage i)) - (let* ((typename (car tl)) - (nused (nth 0 l)) - (nfree (nth 1 l)) - (npage (nth 2 l)) - (maxpage (nth 3 l)) - (gbccount (nth 4 l))) - (if nused - (push (list typename npage maxpage - (if (zerop (+ nused nfree)) - 0 - (/ nused 0.01 (+ nused nfree))) - (if (zerop gbccount) nil gbccount)) - info-list) - (let ((a (assoc (nth nfree type-list) link-alist))) - (if a - (nconc a (list typename)) - (push (list (nth nfree type-list) typename) - link-alist)))))) + (type-list '(cons + ;; fixnum Beppe + fixnum char + bignum ratio short-float long-float complex + symbol package hash-table + array vector string bit-vector + stream random-state readtable pathname + bytecodes cfun cclosure + #-clos structure #+clos instance #+clos generic-function + #+threads mp::process #+threads mp::lock + si::foreign)) + (tl type-list (cdr tl)) + (i 0 (+ i (if (nth 2 l) (nth 2 l) 0)))) + ((null l) (setq npage i)) + (let* ((typename (car tl)) + (nused (nth 0 l)) + (nfree (nth 1 l)) + (npage (nth 2 l)) + (maxpage (nth 3 l)) + (gbccount (nth 4 l))) + (if nused + (push (list typename npage maxpage + (if (zerop (+ nused nfree)) + 0 + (/ nused 0.01 (+ nused nfree))) + (if (zerop gbccount) nil gbccount)) + info-list) + (let ((a (assoc (nth nfree type-list) link-alist))) + (if a + (nconc a (list typename)) + (push (list (nth nfree type-list) typename) + link-alist)))))) (dolist (info (nreverse info-list)) - (apply #'format t "~4D/~D~10T~5,1F%~@[~3D~]~20T~{~A~^ ~}" - (append (cdr info) - (if (assoc (car info) link-alist) - (list (assoc (car info) link-alist)) - (list (list (car info)))))) - (terpri) - ) + (apply #'format t "~4D/~D~10T~5,1F%~@[~3D~]~20T~{~A~^ ~}" + (append (cdr info) + (if (assoc (car info) link-alist) + (list (assoc (car info) link-alist)) + (list (list (car info)))))) + (terpri) + ) (terpri) (format t "~4D/~D~16T~@[~3D~]~20Tcontiguous (~D blocks)~%" - ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) + ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) (format t "~5T~D~20Thole~%" holepage) (format t "~5D pages for cells~%" npage) (format t "~5D total pages~%" (+ npage ncbpage holepage)) (format t "~5D pages available~%" leftpage) (format t "~5D pages in heap but not gc'd + pages needed for gc marking~%" - (- maxpage (+ npage ncbpage holepage leftpage))) + (- maxpage (+ npage ncbpage holepage leftpage))) (format t "~5D maximum pages~%" maxpage) (values) ))) @@ -157,16 +157,16 @@ greeting message to ECL beginners. Welcome to ECL. Here are the few functions you should learn first. - (HELP symbol) prints the online documentation associated with the - symbol. For example, (HELP 'CONS) will print the useful information - about the CONS function, the CONS data type, and so on. + (HELP symbol) prints the online documentation associated with the + symbol. For example, (HELP 'CONS) will print the useful information + about the CONS function, the CONS data type, and so on. - (HELP* string) prints the online documentation associated with those - symbols whose print-names have the string as substring. For example, - (HELP* \"PROG\") will print the documentation of the symbols such as - PROG, PROGN, and MULTIPLE-VALUE-PROG1. + (HELP* string) prints the online documentation associated with those + symbols whose print-names have the string as substring. For example, + (HELP* \"PROG\") will print the documentation of the symbols such as + PROG, PROGN, and MULTIPLE-VALUE-PROG1. - (QUIT) ends the current ECL session. + (QUIT) ends the current ECL session. For the precise language specification, refer to Guy Steele's \"Common Lisp, the Language\" and our \"ECL Manual\". \"ECL Dictionary\", the hard-copied @@ -178,76 +178,76 @@ Good luck! ;;; Pretty-print-formats. ;;; -;;; The number N as the property of a symbol SYMBOL indicates that, -;;; in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM -;;; are the 'body' of the form and thus are treated in a special way by -;;; the ECL pretty-printer. +;;; The number N as the property of a symbol SYMBOL indicates that, +;;; in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM +;;; are the 'body' of the form and thus are treated in a special way by +;;; the ECL pretty-printer. ;;; (At boot we don't have setf yet) #-cmu-format (mapc #'(lambda (x) (put-sysprop (first x) 'sys::pretty-print-format (second x))) '((block 1) - (case 1) - (catch 1) - (ccase 1) - (clines 0) - (compiler-let 1) - (cond 0) - (ctypecase 1) - (defcfun 2) - (define-setf-method 2) - (defla 2) - (defmacro 2) - (defsetf 3) - (defstruct 1) - (deftype 2) - (defun 2) - (do 2) - (do* 2) - (do-symbols 1) - (do-all-symbols 1) - (do-external-symbols 1) - (dolist 1) - (dotimes 1) - (ecase 1) - (etypecase 1) - (eval-when 1) - (flet 1) - (labels 1) - (lambda 1) - (ext::lambda-block 2) - (let 1) - (let* 1) - (locally 0) - (loop 0) - (macrolet 1) - (multiple-value-bind 2) - (multiple-value-prog1 1) - (prog 1) - (prog* 1) - (prog1 1) - (prog2 2) - (progn 0) - (progv 2) - (return 0) - (return-from 1) - (tagbody 0) - (the 1) - (throw 1) - (typecase 1) - (unless 1) - (unwind-protect 0) - (when 1) - (with-input-from-string 1) - (with-open-file 1) - (with-open-stream 1) - (with-output-to-string 1) -#+clos (defclass 2) -#+clos (defmethod 2) -#+clos (symbol-macrolet 2) -#+clos (with-accessors 2) -#+clos (with-slots 2))) + (case 1) + (catch 1) + (ccase 1) + (clines 0) + (compiler-let 1) + (cond 0) + (ctypecase 1) + (defcfun 2) + (define-setf-method 2) + (defla 2) + (defmacro 2) + (defsetf 3) + (defstruct 1) + (deftype 2) + (defun 2) + (do 2) + (do* 2) + (do-symbols 1) + (do-all-symbols 1) + (do-external-symbols 1) + (dolist 1) + (dotimes 1) + (ecase 1) + (etypecase 1) + (eval-when 1) + (flet 1) + (labels 1) + (lambda 1) + (ext::lambda-block 2) + (let 1) + (let* 1) + (locally 0) + (loop 0) + (macrolet 1) + (multiple-value-bind 2) + (multiple-value-prog1 1) + (prog 1) + (prog* 1) + (prog1 1) + (prog2 2) + (progn 0) + (progv 2) + (return 0) + (return-from 1) + (tagbody 0) + (the 1) + (throw 1) + (typecase 1) + (unless 1) + (unwind-protect 0) + (when 1) + (with-input-from-string 1) + (with-open-file 1) + (with-open-stream 1) + (with-output-to-string 1) +#+clos (defclass 2) +#+clos (defmethod 2) +#+clos (symbol-macrolet 2) +#+clos (with-accessors 2) +#+clos (with-slots 2))) ;;; Import functions which are useful for user interaction diff --git a/src/lsp/cmdline.lsp b/src/lsp/cmdline.lsp index 6fd9e6834..613000580 100644 --- a/src/lsp/cmdline.lsp +++ b/src/lsp/cmdline.lsp @@ -64,12 +64,12 @@ appeared after a '--'.") ("-nodebug" 0 (setf *command-break-enable* nil)) ("-eval" 1 (eval (read-from-string 1))) ("-shell" 1 (progn (setq quit 0) - (setq ext:*unprocessed-ecl-command-args* (rest 1)) - (load (first (rest 1)) :verbose nil)) + (setq ext:*unprocessed-ecl-command-args* (rest 1)) + (load (first (rest 1)) :verbose nil)) :stop) ("-load" 1 (load 1 :verbose verbose)) ("-dir" 1 (setf (logical-pathname-translations "SYS") - `(("**;*.*" ,(merge-pathnames "**/*.*" (truename 1)))))) + `(("**;*.*" ,(merge-pathnames "**/*.*" (truename 1)))))) ("--heap-size" 1 (ext:set-limit 'ext:heap-size (read-from-string 1))) ("--lisp-stack" 1 (ext:set-limit 'ext:lisp-stack (read-from-string 1))) ("--frame-stack" 1 (ext:set-limit 'ext:frame-stack (read-from-string 1))) @@ -88,22 +88,22 @@ appeared after a '--'.") ("-compile" 1 (progn (setq quit - (if (nth-value 3 - (compile-file 1 :output-file output-file :c-file c-file - :h-file h-file :data-file data-file - :verbose verbose :system-p system-p)) - 1 - 0) - output-file t - c-file nil - h-file nil - data-file nil - system-p nil))) + (if (nth-value 3 + (compile-file 1 :output-file output-file :c-file c-file + :h-file h-file :data-file data-file + :verbose verbose :system-p system-p)) + 1 + 0) + output-file t + c-file nil + h-file nil + data-file nil + system-p nil))) ("-link" &rest (progn (require 'cmp) (funcall (read-from-string "c::build-program") - (or output-file "lisp.exe") :lisp-files '&rest) + (or output-file "lisp.exe") :lisp-files '&rest) (setq output-file t quit t))) ("-o" &optional (setq output-file 1)) ("-c" &optional (setq c-file 1)) @@ -118,29 +118,29 @@ appeared after a '--'.") (defun produce-init-code (option-list rules) (do* ((commands '()) (stop nil) - (loadrc t)) + (loadrc t)) ((or stop (null option-list)) - (values `(let ((output-file t) - (c-file nil) - (h-file nil) - (data-file nil) - (verbose t) - (system-p nil) - (quit nil) + (values `(let ((output-file t) + (c-file nil) + (h-file nil) + (data-file nil) + (verbose t) + (system-p nil) + (quit nil) (*command-break-enable* nil)) - ,@(nreverse commands) - (when quit (quit 0))) - loadrc - option-list)) + ,@(nreverse commands) + (when quit (quit 0))) + loadrc + option-list)) (let* ((option (pop option-list)) - (rule (assoc option rules :test #'string=))) + (rule (assoc option rules :test #'string=))) (unless rule - ;; If there is a default rule, group all remaining arguments - ;; including the unmatched one, and pass them to this rule. - (setf rule (assoc "*DEFAULT*" rules :test #'string=) - stop t) - (unless rule - (command-arg-error "Unknown command line option ~A.~%" option))) + ;; If there is a default rule, group all remaining arguments + ;; including the unmatched one, and pass them to this rule. + (setf rule (assoc "*DEFAULT*" rules :test #'string=) + stop t) + (unless rule + (command-arg-error "Unknown command line option ~A.~%" option))) (case (fourth rule) (:noloadrc (setf loadrc nil)) (:loadrc (setf loadrc t)) @@ -148,33 +148,33 @@ appeared after a '--'.") stop t))) (let ((pattern (copy-tree (third rule))) (noptions (second rule))) - (cond ((equal noptions 0) - ;; No extra arguments - ) - ((and (equal noptions '&optional) - (or (null option-list) - (assoc (first option-list) rules :test #'string=))) - ;; The argument is optional and the next command line option is - ;; either absent or it is a valid command line option - (nsubst t 1 pattern)) - ((null option-list) - (command-arg-error - "Missing argument after command line option ~A.~%" - option)) - ((or (eq noptions 'rest) (eq noptions '&rest)) - (nsubst option-list noptions pattern) - (setf option-list nil)) - (t - (nsubst (pop option-list) 1 pattern))) + (cond ((equal noptions 0) + ;; No extra arguments + ) + ((and (equal noptions '&optional) + (or (null option-list) + (assoc (first option-list) rules :test #'string=))) + ;; The argument is optional and the next command line option is + ;; either absent or it is a valid command line option + (nsubst t 1 pattern)) + ((null option-list) + (command-arg-error + "Missing argument after command line option ~A.~%" + option)) + ((or (eq noptions 'rest) (eq noptions '&rest)) + (nsubst option-list noptions pattern) + (setf option-list nil)) + (t + (nsubst (pop option-list) 1 pattern))) (push pattern commands))))) (defun process-command-args (&key - (args (rest *command-args*)) - (rules +default-command-arg-rules+)) + (args (rest *command-args*)) + (rules +default-command-arg-rules+)) "PROCESS-COMMAND-ARGS takes a list of arguments and processes according to a set of rules. These rules are of the format - (option-name nargs template [ :stop | :noloadrc | :loadrc ] ) + (option-name nargs template [ :stop | :noloadrc | :loadrc ] ) OPTION-NAME is a string containing the command line option. NARGS is the number of arguments that this option takes. TEMPLATE is a lisp diff --git a/src/lsp/cmuutil.lsp b/src/lsp/cmuutil.lsp index cfec649e5..889a5ae3a 100644 --- a/src/lsp/cmuutil.lsp +++ b/src/lsp/cmuutil.lsp @@ -29,17 +29,17 @@ evaluation of Body. Within the body, each Var is bound to the corresponding temporary variable." (labels ((frob (specs body) - (if (null specs) - `(progn ,@body) - (let ((spec (first specs))) - (when (/= (length spec) 2) - (error "Malformed Once-Only binding spec: ~S." spec)) - (let ((name (first spec)) - (exp-temp (gensym))) - `(let ((,exp-temp ,(second spec)) - (,name (gensym "OO-"))) - `(let ((,,name ,,exp-temp)) - ,,(frob (rest specs) body)))))))) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (when (/= (length spec) 2) + (error "Malformed Once-Only binding spec: ~S." spec)) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "OO-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) (frob specs body))) ;;;; The Collect macro: @@ -65,13 +65,13 @@ (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) + `(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))) @@ -100,26 +100,26 @@ position, including macros and lambdas." (let ((macros ()) - (binds ())) + (binds ())) (dolist (spec collections) (unless (<= 1 (length spec) 3) - (error "Malformed collection specifier: ~S." spec)) + (error "Malformed collection specifier: ~S." spec)) (let ((n-value (gensym)) - (name (first spec)) - (default (second spec)) - (kind (or (third spec) 'collect))) - (push `(,n-value ,default) binds) - (if (eq kind 'collect) - (let ((n-tail (gensym))) - (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)))) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (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)))) ); eval-when @@ -151,5 +151,5 @@ "Rewrites the given forms replacing the given symbols with uninterned ones, which is useful for creating hygienic macros." `(progn ,@(sublis (mapcar #'(lambda (s) (cons s (make-symbol (symbol-name s)))) - symbols) - body))) + symbols) + body))) diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 42cb36119..ee8bb9d6d 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -13,17 +13,17 @@ #+(and (not ecl-min) uname) (defun uname () (ffi:c-inline () () :object "{ - cl_object output; - struct utsname aux; - if (uname(&aux) < 0) - output = ECL_NIL; - else - output = cl_list(5, make_base_string_copy(aux.sysname), - make_base_string_copy(aux.nodename), - make_base_string_copy(aux.release), - make_base_string_copy(aux.version), - make_base_string_copy(aux.machine)); - @(return) = output; + cl_object output; + struct utsname aux; + if (uname(&aux) < 0) + output = ECL_NIL; + else + output = cl_list(5, make_base_string_copy(aux.sysname), + make_base_string_copy(aux.nodename), + make_base_string_copy(aux.release), + make_base_string_copy(aux.version), + make_base_string_copy(aux.machine)); + @(return) = output; }" :one-liner nil)) ;; @@ -92,9 +92,9 @@ Returns, as a string, the type of the software under which ECL runs." Returns, as a string, the version of the software under which ECL runs." (or #+uname (third (uname)) #.(let ((aux "@SOFTWARE_VERSION@")) - (if (plusp (length aux)) - aux - nil)))) + (if (plusp (length aux)) + aux + nil)))) ;; ;; * Set up some room @@ -115,12 +115,12 @@ Returns, as a string, the version of the software under which ECL runs." `(("**;*.*" ,(merge-pathnames "**/*.*" (user-homedir-pathname))))) (let (x) (cond ((and (setf x (ext:getenv "TMPDIR")) - (probe-file x))) - ((and (setf x (ext:getenv "TEMP")) - (probe-file x))) - ((and (setf x (ext:getenv "TMP")) - (probe-file x))) - (t (setf x #+unix "/tmp" #-unix "./"))) + (probe-file x))) + ((and (setf x (ext:getenv "TEMP")) + (probe-file x))) + ((and (setf x (ext:getenv "TMP")) + (probe-file x))) + (t (setf x #+unix "/tmp" #-unix "./"))) (si::pathname-translations "TMP" `(("**;*.*" ,(format nil "~A/**/*.*" x))))) diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index e99f1b012..d058eaa46 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -16,47 +16,47 @@ #+ecl-min (si::fset 'push - #'(ext::lambda-block push (args env) - (let* ((what (second args)) - (where (caddr args))) - `(setq ,where (cons ,what ,where)))) - t) + #'(ext::lambda-block push (args env) + (let* ((what (second args)) + (where (caddr args))) + `(setq ,where (cons ,what ,where)))) + t) #+ecl-min (si::fset 'pop - #'(ext::lambda-block pop (args env) - (let ((where (cadr args))) - `(let* ((l ,where) - (v (car l))) - (setq ,where (cdr l)) - v))) - t) + #'(ext::lambda-block pop (args env) + (let ((where (cadr args))) + `(let* ((l ,where) + (v (car l))) + (setq ,where (cdr l)) + v))) + t) #+ecl-min (si::fset 'incf - #'(ext::lambda-block incf (args env) - (let* ((where (second args)) - (what (caddr args))) - (if what - `(setq ,where (+ ,where ,what)) - `(setq ,where (1+ ,where))))) - t) + #'(ext::lambda-block incf (args env) + (let* ((where (second args)) + (what (caddr args))) + (if what + `(setq ,where (+ ,where ,what)) + `(setq ,where (1+ ,where))))) + t) #+ecl-min (si::fset 'decf - #'(ext::lambda-block decf (args env) - (let* ((where (second args)) - (what (caddr args))) - (if what - `(setq ,where (- ,where ,what)) - `(setq ,where (1- ,where))))) - t) + #'(ext::lambda-block decf (args env) + (let* ((where (second args)) + (what (caddr args))) + (if what + `(setq ,where (- ,where ,what)) + `(setq ,where (1- ,where))))) + t) (defun sys::search-keyword (list key) (cond ((atom list) 'missing-keyword) - ((atom (cdr list)) 'missing-keyword) - ((eq (car list) key) (cadr list)) - (t (search-keyword (cddr list) key)))) + ((atom (cdr list)) 'missing-keyword) + ((eq (car list) key) (cadr list)) + (t (search-keyword (cddr list) key)))) (defun check-keyword (tail keywords &optional (allow-other-keys nil aok-flag)) (do (head @@ -64,7 +64,7 @@ (err nil)) ((null tail) (when (and err (not allow-other-keys)) - (error "The key ~s is not allowed" err))) + (error "The key ~s is not allowed" err))) (if (atom tail) (error "keyword list is not a proper list") (setq head (car tail) tail (cdr tail))) @@ -72,137 +72,137 @@ (error "keyword list is not a proper list") (setq arg (car tail) tail (cdr tail))) (cond ((eq head :allow-other-keys) - (when (not aok-flag) - (setq allow-other-keys tail aok-flag t))) - ((not (member head keywords)) - (setq err head))))) + (when (not aok-flag) + (setq allow-other-keys tail aok-flag t))) + ((not (member head keywords)) + (setq err head))))) (defun dm-too-many-arguments (*current-form*) (error "Too many arguments supplied to a macro or a destructuring-bind form:~%~s" - *current-form*)) + *current-form*)) (defun dm-too-few-arguments (form-or-nil) (if form-or-nil (let ((*current-form* form-or-nil)) - (error "Too few arguments supplied to a macro or a destructuring-bind form:~%~S" - *current-form*)) + (error "Too few arguments supplied to a macro or a destructuring-bind form:~%~S" + *current-form*)) (error "Too few arguments supplied to a inlined lambda form."))) (defun sys::destructure (vl macro &aux (basis-form (gensym)) (destructure-symbols (list basis-form))) (declare (si::c-local) - (special *dl* *arg-check*)) + (special *dl* *arg-check*)) (labels ((tempsym () - (let ((x (gensym))) - (push x destructure-symbols) - x)) - (dm-vl (vl whole macro) - (multiple-value-bind (reqs opts rest key-flag keys allow-other-keys auxs) - (si::process-lambda-list vl (if macro 'macro 'destructuring-bind)) - (let* ((pointer (tempsym)) - (cons-pointer `(truly-the cons ,pointer)) - (unsafe-car `(car ,cons-pointer)) - (unsafe-cdr `(cdr ,cons-pointer)) - (unsafe-pop `(setq ,pointer ,unsafe-cdr)) - (no-check nil) - (ppn (+ (length reqs) (first opts))) - all-keywords) - ;; In macros, eliminate the name of the macro from the list - (dm-v pointer (if macro `(cdr (truly-the cons ,whole)) whole)) - (dolist (v (cdr reqs)) - (dm-v v `(progn - (if (null ,pointer) - (dm-too-few-arguments ,basis-form)) - (prog1 ,unsafe-car ,unsafe-pop)))) - (dotimes (i (pop opts)) - (let* ((x (first opts)) - (init (second opts)) - (sv (third opts))) - (setq opts (cdddr opts)) - (cond (sv - (dm-v x `(if ,pointer ,unsafe-car ,init)) - (dm-v sv `(and ,pointer (progn ,unsafe-pop t)))) - (t - (dm-v x `(if ,pointer - (prog1 ,unsafe-car ,unsafe-pop) - ,init)))))) - (when rest - (dm-v rest pointer) - (setq no-check t)) - (dotimes (i (pop keys)) - (let* ((temp (tempsym)) - (k (first keys)) - (v (second keys)) - (init (third keys)) - (sv (fourth keys))) - (setq no-check t) - (setq keys (cddddr keys)) - (dm-v temp `(search-keyword ,pointer ',k)) - (dm-v v `(if (eq ,temp 'missing-keyword) ,init ,temp)) - (when sv (dm-v sv `(not (eq ,temp 'missing-keyword)))) - (push k all-keywords))) - (do ((l auxs (cddr l))) ((endp l)) - (let* ((v (first l)) - (init (second l))) - (dm-v v init))) - (cond (key-flag - (push `(check-keyword ,pointer ',all-keywords - ,@(if allow-other-keys '(t) '())) - *arg-check*)) - ((not no-check) - (push `(if ,pointer (dm-too-many-arguments ,basis-form)) - *arg-check*))) - ppn))) + (let ((x (gensym))) + (push x destructure-symbols) + x)) + (dm-vl (vl whole macro) + (multiple-value-bind (reqs opts rest key-flag keys allow-other-keys auxs) + (si::process-lambda-list vl (if macro 'macro 'destructuring-bind)) + (let* ((pointer (tempsym)) + (cons-pointer `(truly-the cons ,pointer)) + (unsafe-car `(car ,cons-pointer)) + (unsafe-cdr `(cdr ,cons-pointer)) + (unsafe-pop `(setq ,pointer ,unsafe-cdr)) + (no-check nil) + (ppn (+ (length reqs) (first opts))) + all-keywords) + ;; In macros, eliminate the name of the macro from the list + (dm-v pointer (if macro `(cdr (truly-the cons ,whole)) whole)) + (dolist (v (cdr reqs)) + (dm-v v `(progn + (if (null ,pointer) + (dm-too-few-arguments ,basis-form)) + (prog1 ,unsafe-car ,unsafe-pop)))) + (dotimes (i (pop opts)) + (let* ((x (first opts)) + (init (second opts)) + (sv (third opts))) + (setq opts (cdddr opts)) + (cond (sv + (dm-v x `(if ,pointer ,unsafe-car ,init)) + (dm-v sv `(and ,pointer (progn ,unsafe-pop t)))) + (t + (dm-v x `(if ,pointer + (prog1 ,unsafe-car ,unsafe-pop) + ,init)))))) + (when rest + (dm-v rest pointer) + (setq no-check t)) + (dotimes (i (pop keys)) + (let* ((temp (tempsym)) + (k (first keys)) + (v (second keys)) + (init (third keys)) + (sv (fourth keys))) + (setq no-check t) + (setq keys (cddddr keys)) + (dm-v temp `(search-keyword ,pointer ',k)) + (dm-v v `(if (eq ,temp 'missing-keyword) ,init ,temp)) + (when sv (dm-v sv `(not (eq ,temp 'missing-keyword)))) + (push k all-keywords))) + (do ((l auxs (cddr l))) ((endp l)) + (let* ((v (first l)) + (init (second l))) + (dm-v v init))) + (cond (key-flag + (push `(check-keyword ,pointer ',all-keywords + ,@(if allow-other-keys '(t) '())) + *arg-check*)) + ((not no-check) + (push `(if ,pointer (dm-too-many-arguments ,basis-form)) + *arg-check*))) + ppn))) - (dm-v (v init) - (cond ((and v (symbolp v)) - (push (if init (list v init) v) *dl*)) - ((and v (atom v)) - (error "destructure: ~A is not a list nor a symbol" v)) - ((eq (first v) '&whole) - (let ((whole-var (second v))) - (if (listp whole-var) - (let ((new-whole (tempsym))) - (dm-v new-whole init) - (dm-vl whole-var new-whole nil) - (setq whole-var new-whole)) - (dm-v whole-var init)) - (dm-vl (cddr v) whole-var nil))) - (t - (let ((temp (tempsym))) - (push (if init (list temp init) temp) *dl*) - (dm-vl v temp nil)))))) + (dm-v (v init) + (cond ((and v (symbolp v)) + (push (if init (list v init) v) *dl*)) + ((and v (atom v)) + (error "destructure: ~A is not a list nor a symbol" v)) + ((eq (first v) '&whole) + (let ((whole-var (second v))) + (if (listp whole-var) + (let ((new-whole (tempsym))) + (dm-v new-whole init) + (dm-vl whole-var new-whole nil) + (setq whole-var new-whole)) + (dm-v whole-var init)) + (dm-vl (cddr v) whole-var nil))) + (t + (let ((temp (tempsym))) + (push (if init (list temp init) temp) *dl*) + (dm-vl v temp nil)))))) (let* ((whole basis-form) - (*dl* nil) - (*arg-check* nil)) + (*dl* nil) + (*arg-check* nil)) (declare (special *dl* *arg-check*)) (cond ((listp vl) - (when (eq (first vl) '&whole) + (when (eq (first vl) '&whole) (let ((named-whole (second vl))) (setq vl (cddr vl)) (if (listp named-whole) (dm-vl named-whole whole nil) (setq *dl* (list (list named-whole whole))))))) - ((symbolp vl) - (setq vl (list '&rest vl))) - (t (error "The destructuring-lambda-list ~s is not a list." vl))) + ((symbolp vl) + (setq vl (list '&rest vl))) + (t (error "The destructuring-lambda-list ~s is not a list." vl))) (values (dm-vl vl whole macro) whole - (nreverse *dl*) + (nreverse *dl*) *arg-check* - destructure-symbols)))) + destructure-symbols)))) ;;; valid lambda-list to DEFMACRO is: ;;; -;;; ( [ &whole sym ] -;;; [ &environment sym ] -;;; { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) +;;; ( [ &whole sym ] +;;; [ &environment sym ] +;;; { v }* +;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] +;;; { [ { &rest | &body } v ] +;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* +;;; [ &allow-other-keys ]] +;;; [ &aux { sym | ( v [ init ] ) }* ] +;;; | . sym } +;;; ) ;;; ;;; where v is short for { defmacro-lambda-list | sym }. ;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case @@ -210,14 +210,14 @@ ;;; (DEFMACRO (&REST ) ...). ;;; Defmacro-lambda-list is defined as: ;;; -;;; ( { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) +;;; ( { v }* +;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] +;;; { [ { &rest | &body } v ] +;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* +;;; [ &allow-other-keys ]] +;;; [ &aux { sym | ( v [ init ] ) }* ] +;;; | . sym } +;;; ) (defun find-documentation (body) (nth-value 3 (process-declarations body t))) @@ -231,7 +231,7 @@ (multiple-value-bind (decls body doc) (process-declarations body doc) (values (if decls `((declare ,@decls)) nil) - body doc))) + body doc))) (defun sys::expand-defmacro (name vl body) (multiple-value-bind (decls body doc) @@ -252,7 +252,7 @@ (multiple-value-bind (ppn whole dl arg-check ignorables) (destructure vl t) (values `(ext::lambda-block ,name (,whole ,env &aux ,@dl) - (declare (ignorable ,@ignorables)) + (declare (ignorable ,@ignorables)) ,@decls ,@arg-check ,@body) @@ -261,33 +261,33 @@ #+ecl-min (si::fset 'defmacro - #'(ext::lambda-block defmacro (def env) + #'(ext::lambda-block defmacro (def env) (declare (ignore env)) - (let* ((name (second def)) - (vl (third def)) - (body (cdddr def)) - (function)) - (multiple-value-bind (function pprint doc) - (sys::expand-defmacro name vl body) - (declare (ignore doc)) - (setq function `(function ,function)) - (when *dump-defmacro-definitions* - (print function) - (setq function `(si::bc-disassemble ,function))) - (ext:register-with-pde def `(si::fset ',name ,function t ,pprint))))) - t) + (let* ((name (second def)) + (vl (third def)) + (body (cdddr def)) + (function)) + (multiple-value-bind (function pprint doc) + (sys::expand-defmacro name vl body) + (declare (ignore doc)) + (setq function `(function ,function)) + (when *dump-defmacro-definitions* + (print function) + (setq function `(si::bc-disassemble ,function))) + (ext:register-with-pde def `(si::fset ',name ,function t ,pprint))))) + t) ;;; valid lambda-list to DESTRUCTURING-BIND is: ;;; -;;; ( [ &whole sym ] -;;; { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) +;;; ( [ &whole sym ] +;;; { v }* +;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] +;;; { [ { &rest | &body } v ] +;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* +;;; [ &allow-other-keys ]] +;;; [ &aux { sym | ( v [ init ] ) }* ] +;;; | . sym } +;;; ) ;;; ;;; where v is short for { destructuring-bind-lambda-list | sym }. ;;; A symbol may be accepted as a DESTRUCTURING-BIND lambda-list, in which case @@ -295,15 +295,15 @@ ;;; (DESTRUCTURING-BIND (&REST ) ...). ;;; Destructuring-bind-lambda-list is defined as: ;;; -;;; ( [ &whole sym ] -;;; { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) +;;; ( [ &whole sym ] +;;; { v }* +;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] +;;; { [ { &rest | &body } v ] +;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* +;;; [ &allow-other-keys ]] +;;; [ &aux { sym | ( v [ init ] ) }* ] +;;; | . sym } +;;; ) (defmacro destructuring-bind (vl list &body body) (multiple-value-bind (decls body) @@ -312,7 +312,7 @@ (destructure vl nil) (declare (ignore ppn)) `(let* ((,whole ,list) ,@dl) - (declare (ignorable ,@ignorables)) + (declare (ignorable ,@ignorables)) ,@decls ,@arg-check ,@body)))) @@ -330,54 +330,54 @@ environment can be used to bytecompile the functions in MACROLET or SYMBOL-MACRO forms, and also to evaluate other forms." (declare (si::c-local)) (flet ((local-var-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error + #'(lambda (whole env) + (declare (ignore whole env)) + (error "In a MACROLET function you tried to access a local variable, ~A, from the function in which it appears." name))) - (local-fun-error-function (name) - #'(lambda (whole env) - (declare (ignore whole env)) - (error + (local-fun-error-function (name) + #'(lambda (whole env) + (declare (ignore whole env)) + (error "In a MACROLET function you tried to access a local function, ~A, from the function in which it appears." name)))) (cons (do ((env (car old-env) (cdr env)) - (variables '())) - ((endp env) (nreverse variables)) - (let ((i (car env))) - (if (consp i) - (let ((name (first i))) - (if (not (keywordp name)) - (push (if (second i) - i - (list name 'si::symbol-macro (local-var-error-function name))) - variables)))))) - (do ((env (cdr old-env) (cdr env)) - (macros '())) - ((endp env) (nreverse macros)) - (let ((i (car env))) - (if (consp i) - (push (if (eq (second i) 'SI::MACRO) - i - (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) - macros))))))) + (variables '())) + ((endp env) (nreverse variables)) + (let ((i (car env))) + (if (consp i) + (let ((name (first i))) + (if (not (keywordp name)) + (push (if (second i) + i + (list name 'si::symbol-macro (local-var-error-function name))) + variables)))))) + (do ((env (cdr old-env) (cdr env)) + (macros '())) + ((endp env) (nreverse macros)) + (let ((i (car env))) + (if (consp i) + (push (if (eq (second i) 'SI::MACRO) + i + (list (first i) 'SI:MACRO (local-fun-error-function (first i)))) + macros))))))) (defun macrolet-functions (definitions old-env) (declare (si::c-local)) (let ((env (cmp-env-for-bytecodes old-env))) (si::eval-with-env (cons 'list - (mapcar #'(lambda (x) - (let* ((name (first x)) - (llist (second x)) - (def (cddr x))) - `(list ',name ,(si::expand-defmacro name llist def)))) - definitions)) + (mapcar #'(lambda (x) + (let* ((name (first x)) + (llist (second x)) + (def (cddr x))) + `(list ',name ,(si::expand-defmacro name llist def)))) + definitions)) env nil t))) (defun cmp-env-register-macrolet (definitions old-env) (let ((macros (cdr old-env))) (dolist (record (macrolet-functions definitions old-env)) (push (list (first record) 'si::macro (second record)) - macros)) + macros)) (rplacd (truly-the cons old-env) macros))) diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index 2885cd06f..5a5189de4 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -2,12 +2,12 @@ ;;;; ;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: (DEFPACKAGE :COLON-MODE :EXTERNAL) -*- ;;; -;;; THE BOEING COMPANY -;;; BOEING COMPUTER SERVICES -;;; RESEARCH AND TECHNOLOGY -;;; COMPUTER SCIENCE -;;; P.O. BOX 24346, MS 7L-64 -;;; SEATTLE, WA 98124-0346 +;;; THE BOEING COMPANY +;;; BOEING COMPUTER SERVICES +;;; RESEARCH AND TECHNOLOGY +;;; COMPUTER SCIENCE +;;; P.O. BOX 24346, MS 7L-64 +;;; SEATTLE, WA 98124-0346 ;;; ;;; ;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved. @@ -28,37 +28,37 @@ ;;; responsibility to anyone for the consequences of using it or for ;;; whether it serves any particular purpose or works at all. ;;; -;;; Author: Stephen L. Nicoud +;;; Author: Stephen L. Nicoud ;;; ;;; ----------------------------------------------------------------- ;;; -;;; Adapted for ECL by Giuseppe Attardi, 6/6/1994. +;;; Adapted for ECL by Giuseppe Attardi, 6/6/1994. ;;; ;;; ----------------------------------------------------------------- ;;; ----------------------------------------------------------------- ;;; -;;; DEFPACKAGE - This files attempts to define a portable -;;; implementation for DEFPACKAGE, as defined in "Common LISP, The -;;; Language", by Guy L. Steele, Jr., Second Edition, 1990, Digital -;;; Press. +;;; DEFPACKAGE - This files attempts to define a portable +;;; implementation for DEFPACKAGE, as defined in "Common LISP, The +;;; Language", by Guy L. Steele, Jr., Second Edition, 1990, Digital +;;; Press. ;;; -;;; Send comments, suggestions, and/or questions to: +;;; Send comments, suggestions, and/or questions to: ;;; -;;; Stephen L Nicoud +;;; Stephen L Nicoud ;;; -;;; An early version of this file was tested in Symbolics Common -;;; Lisp (Genera 7.2 & 8.0 on a Symbolics 3650 Lisp Machine), -;;; Franz's Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS -;;; 4.1), and Sun Common Lisp (Lucid Common Lisp 3.0.2 on a Sun 3, -;;; SunOS 4.1). +;;; An early version of this file was tested in Symbolics Common +;;; Lisp (Genera 7.2 & 8.0 on a Symbolics 3650 Lisp Machine), +;;; Franz's Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS +;;; 4.1), and Sun Common Lisp (Lucid Common Lisp 3.0.2 on a Sun 3, +;;; SunOS 4.1). ;;; -;;; 91/5/23 (SLN) - Since the initial testing, modifications have -;;; been made to reflect new understandings of what DEFPACKAGE -;;; should do. These new understandings are the result of -;;; discussions appearing on the X3J13 and Common Lisp mailing -;;; lists. Cursory testing was done on the modified version only -;;; in Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS 4.1). +;;; 91/5/23 (SLN) - Since the initial testing, modifications have +;;; been made to reflect new understandings of what DEFPACKAGE +;;; should do. These new understandings are the result of +;;; discussions appearing on the X3J13 and Common Lisp mailing +;;; lists. Cursory testing was done on the modified version only +;;; in Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS 4.1). ;;; ;;; ----------------------------------------------------------------- @@ -66,7 +66,7 @@ (defmacro DEFPACKAGE (name &rest options) (declare (type (or symbol string character) name)) - "DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] + "DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] This creates a new package, or modifies an existing one, whose name is DEFINED-PACKAGE-NAME. The DEFINED-PACKAGE-NAME may be a string or a @@ -80,122 +80,122 @@ of the same kind may occur within the same DEFPACKAGE form. Valid Options: - (:documentation string) - (:size integer) - (:nicknames {package-name}*) - (:shadow {symbol-name}*) - (:shadowing-import-from package-name {symbol-name}*) - (:use {package-name}*) - (:import-from package-name {symbol-name}*) - (:intern {symbol-name}*) - (:export {symbol-name}*) - (:export-from {package-name}*) + (:documentation string) + (:size integer) + (:nicknames {package-name}*) + (:shadow {symbol-name}*) + (:shadowing-import-from package-name {symbol-name}*) + (:use {package-name}*) + (:import-from package-name {symbol-name}*) + (:intern {symbol-name}*) + (:export {symbol-name}*) + (:export-from {package-name}*) [Note: :EXPORT-FROM is an extension to DEFPACKAGE. - If a symbol is interned in the package being created and - if a symbol with the same print name appears as an external - symbol of one of the packages in the :EXPORT-FROM option, - then the symbol is exported from the package being created. + If a symbol is interned in the package being created and + if a symbol with the same print name appears as an external + symbol of one of the packages in the :EXPORT-FROM option, + then the symbol is exported from the package being created. - :DOCUMENTATION is an extension to DEFPACKAGE. + :DOCUMENTATION is an extension to DEFPACKAGE. - :SIZE is used only in Genera and Allegro.]" + :SIZE is used only in Genera and Allegro.]" (dolist (option options) (unless (member (first option) - '(:DOCUMENTATION :SIZE :NICKNAMES :SHADOW - :SHADOWING-IMPORT-FROM :USE :IMPORT-FROM :INTERN :EXPORT - :EXPORT-FROM) :test #'eq) + '(:DOCUMENTATION :SIZE :NICKNAMES :SHADOW + :SHADOWING-IMPORT-FROM :USE :IMPORT-FROM :INTERN :EXPORT + :EXPORT-FROM) :test #'eq) (cerror "Proceed, ignoring this option." - "~s is not a valid DEFPACKAGE option." option))) + "~s is not a valid DEFPACKAGE option." option))) (labels ((to-string (x) (if (numberp x) x (string x))) - (option-values-list (option options &aux output) - (dolist (o options) - (let ((o-option (first o))) - (when (string= o-option option) - (let* ((o-package (string (second o))) - (former-symbols (assoc o-package output)) - (o-symbols (union (mapcar #'to-string (cddr o)) - (cdr former-symbols) - :test #'equal))) - (if former-symbols - (setf (cdr former-symbols) o-symbols) - (setq output (acons o-package o-symbols output))))))) - output) - (option-values (option options &aux output) - (dolist (o options) - (let* ((o-option (first o)) - (o-symbols (mapcar #'to-string (cdr o)))) - (when (string= o-option option) - (setq output (union o-symbols output :test #'equal))))) - output)) + (option-values-list (option options &aux output) + (dolist (o options) + (let ((o-option (first o))) + (when (string= o-option option) + (let* ((o-package (string (second o))) + (former-symbols (assoc o-package output)) + (o-symbols (union (mapcar #'to-string (cddr o)) + (cdr former-symbols) + :test #'equal))) + (if former-symbols + (setf (cdr former-symbols) o-symbols) + (setq output (acons o-package o-symbols output))))))) + output) + (option-values (option options &aux output) + (dolist (o options) + (let* ((o-option (first o)) + (o-symbols (mapcar #'to-string (cdr o)))) + (when (string= o-option option) + (setq output (union o-symbols output :test #'equal))))) + output)) (dolist (option '(:SIZE :DOCUMENTATION)) (when (<= 2 (count option options ':key #'car)) - (si::simple-program-error "DEFPACKAGE option ~s specified more than once." - option))) + (si::simple-program-error "DEFPACKAGE option ~s specified more than once." + option))) (setq name (string name)) (let* ((nicknames (option-values ':nicknames options)) - (documentation (option-values ':documentation options)) - (shadowed-symbol-names (option-values ':shadow options)) - (interned-symbol-names (option-values ':intern options)) - (exported-symbol-names (option-values ':export options)) - (shadowing-imported-from-symbol-names-list - (option-values-list ':shadowing-import-from options)) - (imported-from-symbol-names-list - (option-values-list ':import-from options)) - (exported-from-package-names (option-values ':export-from options))) + (documentation (option-values ':documentation options)) + (shadowed-symbol-names (option-values ':shadow options)) + (interned-symbol-names (option-values ':intern options)) + (exported-symbol-names (option-values ':export options)) + (shadowing-imported-from-symbol-names-list + (option-values-list ':shadowing-import-from options)) + (imported-from-symbol-names-list + (option-values-list ':import-from options)) + (exported-from-package-names (option-values ':export-from options))) (dolist (duplicate (find-duplicates shadowed-symbol-names - interned-symbol-names - (loop for list in shadowing-imported-from-symbol-names-list append (rest list)) - (loop for list in imported-from-symbol-names-list append (rest list)))) - (si::simple-program-error - "The symbol ~s cannot coexist in these lists:~{ ~s~}" - (first duplicate) - (loop for num in (rest duplicate) - collect (case num - (1 ':SHADOW) - (2 ':INTERN) - (3 ':SHADOWING-IMPORT-FROM) - (4 ':IMPORT-FROM))))) + interned-symbol-names + (loop for list in shadowing-imported-from-symbol-names-list append (rest list)) + (loop for list in imported-from-symbol-names-list append (rest list)))) + (si::simple-program-error + "The symbol ~s cannot coexist in these lists:~{ ~s~}" + (first duplicate) + (loop for num in (rest duplicate) + collect (case num + (1 ':SHADOW) + (2 ':INTERN) + (3 ':SHADOWING-IMPORT-FROM) + (4 ':IMPORT-FROM))))) (dolist (duplicate (find-duplicates exported-symbol-names - interned-symbol-names)) - (si::simple-program-error - "The symbol ~s cannot coexist in these lists:~{ ~s~}" - (first duplicate) - (loop for num in (rest duplicate) collect - (case num - (1 ':EXPORT) - (2 ':INTERN))))) + interned-symbol-names)) + (si::simple-program-error + "The symbol ~s cannot coexist in these lists:~{ ~s~}" + (first duplicate) + (loop for num in (rest duplicate) collect + (case num + (1 ':EXPORT) + (2 ':INTERN))))) `(eval-when (eval compile load) (si::dodefpackage - ,name - ',nicknames - ,(car documentation) - ',(if (assoc ':use options) (option-values ':use options) "CL") - ',shadowed-symbol-names - ',interned-symbol-names - ',exported-symbol-names - ',shadowing-imported-from-symbol-names-list - ',imported-from-symbol-names-list - ',exported-from-package-names))))) + ,name + ',nicknames + ,(car documentation) + ',(if (assoc ':use options) (option-values ':use options) "CL") + ',shadowed-symbol-names + ',interned-symbol-names + ',exported-symbol-names + ',shadowing-imported-from-symbol-names-list + ',imported-from-symbol-names-list + ',exported-from-package-names))))) (defun dodefpackage (name - nicknames - documentation - use - shadowed-symbol-names - interned-symbol-names - exported-symbol-names - shadowing-imported-from-symbol-names-list - imported-from-symbol-names-list - exported-from-package-names) + nicknames + documentation + use + shadowed-symbol-names + interned-symbol-names + exported-symbol-names + shadowing-imported-from-symbol-names-list + imported-from-symbol-names-list + exported-from-package-names) (if (find-package name) (progn ; (rename-package name name) (when nicknames - (rename-package name name nicknames)) + (rename-package name name nicknames)) (when use - (unuse-package (package-use-list (find-package name)) name))) + (unuse-package (package-use-list (find-package name)) name))) (make-package name :use nil :nicknames nicknames)) (let ((*package* (find-package name))) (when documentation @@ -203,22 +203,22 @@ (shadow shadowed-symbol-names) (dolist (item shadowing-imported-from-symbol-names-list) (let ((package (find-package (first item)))) - (dolist (name (rest item)) - (shadowing-import (find-or-make-symbol name package))))) + (dolist (name (rest item)) + (shadowing-import (find-or-make-symbol name package))))) (use-package use) (dolist (item imported-from-symbol-names-list) (let ((package (find-package (first item)))) - (dolist (name (rest item)) - ;; IMPORT can accept a list as argument, hence if we want to - ;; import symbol NIL, we have to enclose it in a list. - (import (or (find-or-make-symbol name package) (list NIL)))))) + (dolist (name (rest item)) + ;; IMPORT can accept a list as argument, hence if we want to + ;; import symbol NIL, we have to enclose it in a list. + (import (or (find-or-make-symbol name package) (list NIL)))))) (mapc #'intern interned-symbol-names) (export (mapcar #'intern exported-symbol-names)) (dolist (package exported-from-package-names) (do-external-symbols (symbol (find-package package)) - (when (nth 1 (multiple-value-list - (find-symbol (string symbol)))) - (export (list (intern (string symbol)))))))) + (when (nth 1 (multiple-value-list + (find-symbol (string symbol)))) + (export (list (intern (string symbol)))))))) (find-package name)) (defun find-or-make-symbol (name package) @@ -227,9 +227,9 @@ (find-symbol name package) (unless found (signal-simple-error 'package-error "INTERN it." - "Cannot find symbol ~S in package ~S" - (list name package) - :package package) + "Cannot find symbol ~S in package ~S" + (list name package) + :package package) (setq symbol (intern name package))) symbol)) @@ -237,24 +237,24 @@ (declare (si::c-local)) (let (results) (loop for list in lists - for more on (cdr lists) - for i from 1 - do - (loop for elt in list - as entry = (find elt results :key #'car - :test #'string=) - unless (member i entry) - do - (loop for l2 in more - for j from (1+ i) - do - (if (member elt l2 :test #'string=) - (if entry - (nconc entry (list j)) - (setq entry (car (push (list elt i j) - results)))))))) + for more on (cdr lists) + for i from 1 + do + (loop for elt in list + as entry = (find elt results :key #'car + :test #'string=) + unless (member i entry) + do + (loop for l2 in more + for j from (1+ i) + do + (if (member elt l2 :test #'string=) + (if entry + (nconc entry (list j)) + (setq entry (car (push (list elt i j) + results)))))))) results)) ;;;; ------------------------------------------------------------ -;;;; End of File +;;;; End of File ;;;; ------------------------------------------------------------ diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 2a0b5f0cd..c50a05975 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -16,43 +16,43 @@ (defun si::structure-type-error (value slot-type struct-name slot-name) (error 'simple-type-error - :format-control "Slot ~A in structure ~A only admits values of type ~A." - :format-arguments (list slot-name struct-name slot-type) - :datum value - :expected-type slot-type)) + :format-control "Slot ~A in structure ~A only admits values of type ~A." + :format-arguments (list slot-name struct-name slot-type) + :datum value + :expected-type slot-type)) (defun make-access-function (name conc-name type named slot-descr) (declare (ignore named) - (si::c-local)) + (si::c-local)) (let* ((slot-name (nth 0 slot-descr)) - ;; (default-init (nth 1 slot-descr)) - ;; (slot-type (nth 2 slot-descr)) - (read-only (nth 3 slot-descr)) - (offset (nth 4 slot-descr)) - (access-function (if conc-name - (intern (base-string-concatenate conc-name slot-name)) - slot-name))) + ;; (default-init (nth 1 slot-descr)) + ;; (slot-type (nth 2 slot-descr)) + (read-only (nth 3 slot-descr)) + (offset (nth 4 slot-descr)) + (access-function (if conc-name + (intern (base-string-concatenate conc-name slot-name)) + slot-name))) (if (eql access-function (sixth slot-descr)) - (return-from make-access-function nil) - (setf (sixth slot-descr) access-function)) + (return-from make-access-function nil) + (setf (sixth slot-descr) access-function)) (cond ((null type) ;; If TYPE is NIL, ;; the slot is at the offset in the structure-body. - (fset access-function #'(lambda (x) - (sys:structure-ref x name offset)))) + (fset access-function #'(lambda (x) + (sys:structure-ref x name offset)))) ((subtypep type '(OR LIST VECTOR)) - ;; If TYPE is VECTOR, (VECTOR ... ) or LIST, ELT is used. + ;; If TYPE is VECTOR, (VECTOR ... ) or LIST, ELT is used. (fset access-function - #'(lambda (x) (elt x offset)))) + #'(lambda (x) (elt x offset)))) (t (error "~S is an illegal structure type." type))) (cond (read-only - (fmakunbound `(setf ,access-function)) - (set-documentation access-function 'SETF nil)) - ;; The following is used by the compiler to expand inline - ;; the accessor - (t - (do-setf-structure-method access-function (or type name) - offset))))) + (fmakunbound `(setf ,access-function)) + (set-documentation access-function 'SETF nil)) + ;; The following is used by the compiler to expand inline + ;; the accessor + (t + (do-setf-structure-method access-function (or type name) + offset))))) (defun do-setf-structure-method (access-function type index) @@ -60,130 +60,130 @@ (put-sysprop access-function 'STRUCTURE-ACCESS (cons type index)) (do-defsetf access-function (cond ((or (eq type 'list) (eq type 'vector)) - #'(lambda (newvalue struct) - `(sys::elt-set ,struct ,index ,newvalue))) - ((consp type) - #'(lambda (newvalue struct) - `(si::aset (the ,type ,struct) ,index ,newvalue))) - (t - #'(lambda (newvalue struct) - `(sys::structure-set ,struct ',type ,index ,newvalue)))))) + #'(lambda (newvalue struct) + `(sys::elt-set ,struct ,index ,newvalue))) + ((consp type) + #'(lambda (newvalue struct) + `(si::aset (the ,type ,struct) ,index ,newvalue))) + (t + #'(lambda (newvalue struct) + `(sys::structure-set ,struct ',type ,index ,newvalue)))))) (defun process-boa-lambda-list (slot-names slot-descriptions boa-list assertions) (declare (si::c-local)) (let ((mentioned-slots '()) - (aux)) + (aux)) ;; With a call to PROCESS-LAMBDA-LIST we ensure that the lambda list is ;; syntactically correct. This simplifies notably the code in the loop. (process-lambda-list (setq boa-list (copy-list boa-list)) 'FUNCTION) ;; Search for &optional or &key arguments without initialization. Also, ;; record all slot names which are initialized by means of the BOA call. (do* ((i boa-list (rest i)) - (slot (first i) (first i)) - (modify nil)) - ((endp i)) + (slot (first i) (first i)) + (modify nil)) + ((endp i)) (cond ((or (eq slot '&optional) (eq slot '&key)) - (setq modify t)) - ((eq slot '&rest) - (setq modify nil)) - ((eq slot '&aux) - (setq aux t modify nil)) - ((eq slot '&allow-other-keys) - ) - ((atom slot) - (push slot mentioned-slots) - (when modify - (setf (first i) - (list slot (second (assoc slot slot-descriptions))))) - (when aux - (setf assertions (delete slot assertions :key 'cadadr)))) - (t - (let ((slot-name (first slot))) - (when (consp slot-name) - (setq slot-name (second slot-name))) - (push slot-name mentioned-slots) - (when (endp (rest slot)) - (when modify - (setf (rest slot) - (list (second (assoc slot-name slot-descriptions))))) - (when aux - (setf assertions (delete slot assertions :key 'cadadr)))))))) + (setq modify t)) + ((eq slot '&rest) + (setq modify nil)) + ((eq slot '&aux) + (setq aux t modify nil)) + ((eq slot '&allow-other-keys) + ) + ((atom slot) + (push slot mentioned-slots) + (when modify + (setf (first i) + (list slot (second (assoc slot slot-descriptions))))) + (when aux + (setf assertions (delete slot assertions :key 'cadadr)))) + (t + (let ((slot-name (first slot))) + (when (consp slot-name) + (setq slot-name (second slot-name))) + (push slot-name mentioned-slots) + (when (endp (rest slot)) + (when modify + (setf (rest slot) + (list (second (assoc slot-name slot-descriptions))))) + (when aux + (setf assertions (delete slot assertions :key 'cadadr)))))))) ;; For all slots not mentioned above, add the default values from ;; the DEFSTRUCT slot description. (let ((other-slots (nset-difference - (delete-if #'consp (copy-list slot-names)) - mentioned-slots))) + (delete-if #'consp (copy-list slot-names)) + mentioned-slots))) (do ((l other-slots (cdr l))) - ((endp l)) - (let* ((slot (assoc (car l) slot-descriptions)) - (slot-init (second slot))) - (when slot-init - (setf (car l) (list (car l) slot-init))))) + ((endp l)) + (let* ((slot (assoc (car l) slot-descriptions)) + (slot-init (second slot))) + (when slot-init + (setf (car l) (list (car l) slot-init))))) (when other-slots - (unless aux - (push '&aux other-slots)) - (setf boa-list (nconc boa-list other-slots))) + (unless aux + (push '&aux other-slots)) + (setf boa-list (nconc boa-list other-slots))) (values boa-list assertions)))) (defun make-constructor (name constructor type named slot-descriptions) (declare (ignore named) - (si::c-local)) + (si::c-local)) ;; CONSTRUCTOR := constructor-name | (constructor-name boa-lambda-list) (let* ((boa-constructor-p (consp constructor)) - (keys (unless boa-constructor-p (list '&key))) - (constructor-name (if boa-constructor-p (first constructor) constructor)) - (slot-names '()) - (assertions '())) + (keys (unless boa-constructor-p (list '&key))) + (constructor-name (if boa-constructor-p (first constructor) constructor)) + (slot-names '()) + (assertions '())) (dolist (slot slot-descriptions - (setq slot-names (nreverse slot-names) keys (nreverse keys))) + (setq slot-names (nreverse slot-names) keys (nreverse keys))) (push (cond ((null slot) - ;; If slot-description is NIL, it is padding for initial-offset. - nil) - ((eql (first slot) 'TYPED-STRUCTURE-NAME) - ;; This slot is the name of a typed structure with name. - (list 'QUOTE (second slot))) - (t - (let* ((slot-name (first slot)) - (slot-type (third slot)) - (offset (fifth slot)) - (init-form (second slot)) - (var-name slot-name)) - ;; Unless BOA constructors are used, we should avoid using - ;; slot names as lambda variables in the constructor. - (unless boa-constructor-p - (setq var-name (copy-symbol slot-name)) - (push (if init-form (list var-name init-form) var-name) - keys)) - ;; We insert type checks for every slot and only in the - ;; case of BOA lists we remove some of these checks for - ;; uninitialized slots. - (unless (eq 'T slot-type) - (push `(unless (typep ,var-name ',slot-type) - (structure-type-error ,var-name ',slot-type ',name ',slot-name)) - assertions)) - var-name))) + ;; If slot-description is NIL, it is padding for initial-offset. + nil) + ((eql (first slot) 'TYPED-STRUCTURE-NAME) + ;; This slot is the name of a typed structure with name. + (list 'QUOTE (second slot))) + (t + (let* ((slot-name (first slot)) + (slot-type (third slot)) + (offset (fifth slot)) + (init-form (second slot)) + (var-name slot-name)) + ;; Unless BOA constructors are used, we should avoid using + ;; slot names as lambda variables in the constructor. + (unless boa-constructor-p + (setq var-name (copy-symbol slot-name)) + (push (if init-form (list var-name init-form) var-name) + keys)) + ;; We insert type checks for every slot and only in the + ;; case of BOA lists we remove some of these checks for + ;; uninitialized slots. + (unless (eq 'T slot-type) + (push `(unless (typep ,var-name ',slot-type) + (structure-type-error ,var-name ',slot-type ',name ',slot-name)) + assertions)) + var-name))) slot-names)) (when boa-constructor-p (setf (values keys assertions) - (process-boa-lambda-list slot-names slot-descriptions - (second constructor) assertions))) + (process-boa-lambda-list slot-names slot-descriptions + (second constructor) assertions))) (cond ((null type) `(defun ,constructor-name ,keys - ,@assertions - #-CLOS + ,@assertions + #-CLOS (sys:make-structure ',name ,@slot-names) - #+CLOS - ;; the class is defined by an enclosing LET form - (sys:make-structure .structure-constructor-class. ,@slot-names))) - ((subtypep type '(VECTOR T)) - `(defun ,constructor-name ,keys - (vector ,@slot-names))) + #+CLOS + ;; the class is defined by an enclosing LET form + (sys:make-structure .structure-constructor-class. ,@slot-names))) + ((subtypep type '(VECTOR T)) + `(defun ,constructor-name ,keys + (vector ,@slot-names))) ((subtypep type 'VECTOR) `(defun ,constructor-name ,keys (make-array ',(list (length slot-names)) - :element-type ',(closest-sequence-type type) - :initial-contents (list ,@slot-names)))) + :element-type ',(closest-sequence-type type) + :initial-contents (list ,@slot-names)))) ((eq type 'LIST) `(defun ,constructor-name ,keys (list ,@slot-names))) @@ -193,30 +193,30 @@ (defun make-predicate (name type named name-offset) (declare (si::c-local)) (cond ((null type) - #'(lambda (x) - (structure-subtype-p x name))) + #'(lambda (x) + (structure-subtype-p x name))) ((or (eq type 'VECTOR) (and (consp type) (eq (car type) 'VECTOR))) ;; The name is at the NAME-OFFSET in the vector. (unless named (error "The structure should be named.")) - #'(lambda (x) - (and (vectorp x) - (> (length x) name-offset) - ;; AKCL has (aref (the (vector t) x).) - ;; which fails with strings - (eq (elt x name-offset) name)))) + #'(lambda (x) + (and (vectorp x) + (> (length x) name-offset) + ;; AKCL has (aref (the (vector t) x).) + ;; which fails with strings + (eq (elt x name-offset) name)))) ((eq type 'LIST) ;; The name is at the NAME-OFFSET in the list. (unless named (error "The structure should be named.")) (if (= name-offset 0) - #'(lambda (x) - (and (consp x) (eq (car x) name))) - #'(lambda (x) - (do ((i name-offset (1- i)) - (y x (cdr y))) - ((= i 0) (and (consp y) (eq (car y) name))) - (declare (fixnum i)) - (unless (consp y) (return nil)))))) + #'(lambda (x) + (and (consp x) (eq (car x) name))) + #'(lambda (x) + (do ((i name-offset (1- i)) + (y x (cdr y))) + ((= i 0) (and (consp y) (eq (car y) name))) + (declare (fixnum i)) + (unless (consp y) (return nil)))))) ((error "~S is an illegal structure type.")))) @@ -227,7 +227,7 @@ (defun parse-slot-description (slot-description offset &optional read-only) (declare (si::c-local)) (let* ((slot-type 'T) - slot-name default-init) + slot-name default-init) (cond ((atom slot-description) (setq slot-name slot-description)) ((endp (cdr slot-description)) @@ -281,8 +281,8 @@ (push new-slot output)))) (defun define-structure (name conc-name type named slots slot-descriptions - copier include print-function print-object constructors - offset name-offset documentation predicate) + copier include print-function print-object constructors + offset name-offset documentation predicate) (create-type-name name) ;; We are going to modify this list!!! (setf slot-descriptions (copy-tree slot-descriptions)) @@ -290,29 +290,29 @@ #+clos (unless type (eval `(defclass ,name ,(and include (list include)) - ,(mapcar - #'(lambda (sd) - (if sd - (list* (first sd) - :initform (second sd) - :initarg - (intern (symbol-name (first sd)) - (find-package 'KEYWORD)) - (when (third sd) (list :type (third sd)))) - nil)) ; for initial offset slots - slot-descriptions) - (:metaclass structure-class)))) + ,(mapcar + #'(lambda (sd) + (if sd + (list* (first sd) + :initform (second sd) + :initarg + (intern (symbol-name (first sd)) + (find-package 'KEYWORD)) + (when (third sd) (list :type (third sd)))) + nil)) ; for initial offset slots + slot-descriptions) + (:metaclass structure-class)))) ;; FIXME! We can do the same with INSTALL-METHOD! #+clos (when print-function (eval `(defmethod print-object ((obj ,name) stream) - (,print-function obj stream 0) - obj))) + (,print-function obj stream 0) + obj))) #+clos (when print-object (eval `(defmethod print-object ((obj ,name) stream) - (,print-object obj stream) - obj))) + (,print-object obj stream) + obj))) (when predicate (fset predicate (make-predicate name type named name-offset))) (put-sysprop name 'DEFSTRUCT-FORM `(defstruct ,name ,@slots)) @@ -329,8 +329,8 @@ (set-documentation name 'STRUCTURE documentation)) (dolist (x slot-descriptions) (and x - (not (eql (car x) 'TYPED-STRUCTURE-NAME)) - (funcall #'make-access-function name conc-name type named x))) + (not (eql (car x) 'TYPED-STRUCTURE-NAME)) + (funcall #'make-access-function name conc-name type named x))) (when copier (fset copier #'copy-structure)) #+clos @@ -358,12 +358,12 @@ Defines a structure named by NAME. The doc-string DOC, if supplied, is saved as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (let*((slot-descriptions slots) - (name (if (consp name&opts) (first name&opts) name&opts)) + (name (if (consp name&opts) (first name&opts) name&opts)) (options (when (consp name&opts) (rest name&opts))) (conc-name (base-string-concatenate name "-")) - (default-constructor (intern (base-string-concatenate "MAKE-" name))) - (copier (intern (base-string-concatenate "COPY-" name))) - (predicate (intern (base-string-concatenate name "-P"))) + (default-constructor (intern (base-string-concatenate "MAKE-" name))) + (copier (intern (base-string-concatenate "COPY-" name))) + (predicate (intern (base-string-concatenate name "-P"))) constructors no-constructor predicate-specified include @@ -396,7 +396,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (unless (get-sysprop v 'IS-A-STRUCTURE) (error "~S is an illegal included structure." v))) (:PRINT-FUNCTION (setq print-function v)) - (:PRINT-OBJECT (setq print-object v)) + (:PRINT-OBJECT (setq print-object v)) (:TYPE (setq type v)) (:INITIAL-OFFSET (setq initial-offset v)) (t (error "~S is an illegal defstruct option." o)))) @@ -408,8 +408,8 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (:CONSTRUCTOR (setq constructors (cons default-constructor constructors))) - (:CONC-NAME - (setq conc-name nil)) + (:CONC-NAME + (setq conc-name nil)) ((:COPIER :PREDICATE :PRINT-FUNCTION :PRINT-OBJECT)) (:NAMED (setq named t)) (t (error "~S is an illegal defstruct option." o)))))) @@ -428,16 +428,16 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; Set OFFSET. (setq offset (if include - (get-sysprop (car include) 'STRUCTURE-OFFSET) - 0)) + (get-sysprop (car include) 'STRUCTURE-OFFSET) + 0)) ;; Increment OFFSET. (when (and type initial-offset) (setq offset (+ offset initial-offset))) (when (and type named) - (unless (or (subtypep '(vector symbol) type) - (subtypep type 'list)) - (error "Structure cannot have type ~S and be :NAMED." type)) + (unless (or (subtypep '(vector symbol) type) + (subtypep type 'list)) + (error "Structure cannot have type ~S and be :NAMED." type)) (setq name-offset offset) (setq offset (1+ offset))) @@ -489,8 +489,8 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; Check the named option and set the predicate. (when (and type (not named)) (when predicate-specified - (error "~S is an illegal structure predicate." - predicate)) + (error "~S is an illegal structure predicate." + predicate)) (setq predicate nil)) (when include (setq include (car include))) @@ -506,22 +506,22 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ;; LOAD-TIME-VALUE. ;; (let ((core `(define-structure ',name ',conc-name ',type ',named ',slots - ',slot-descriptions ',copier ',include - ',print-function ',print-object ',constructors - ',offset ',name-offset - ',documentation ',predicate)) - (constructors (mapcar #'(lambda (constructor) - (make-constructor name constructor type named - slot-descriptions)) - constructors))) + ',slot-descriptions ',copier ',include + ',print-function ',print-object ',constructors + ',offset ',name-offset + ',documentation ',predicate)) + (constructors (mapcar #'(lambda (constructor) + (make-constructor name constructor type named + slot-descriptions)) + constructors))) `(progn - (eval-when (:compile-toplevel :load-toplevel) - ,core - ,(si::register-with-pde whole) - ,@(subst `(load-time-value (find-class ',name)) - '.structure-constructor-class. - constructors)) - (eval-when (:execute) - (let ((.structure-constructor-class. ,core)) - ,@constructors)) - ',name)))) + (eval-when (:compile-toplevel :load-toplevel) + ,core + ,(si::register-with-pde whole) + ,@(subst `(load-time-value (find-class ',name)) + '.structure-constructor-class. + constructors)) + (eval-when (:execute) + (let ((.structure-constructor-class. ,core)) + ,@constructors)) + ',name)))) diff --git a/src/lsp/defsys.lsp.in b/src/lsp/defsys.lsp.in index e7d5d5f2a..db6e4a1cb 100644 --- a/src/lsp/defsys.lsp.in +++ b/src/lsp/defsys.lsp.in @@ -1,50 +1,50 @@ ;;; ---------------------------------------------------------------------- -;;; COMMON LISP LIBRARY +;;; COMMON LISP LIBRARY ;;; ---------------------------------------------------------------------- (defparameter *lsp-modules* - ;; file load compile files which force - ;; environment environment recompilations of - ;; this file + ;; file load compile files which force + ;; environment environment recompilations of + ;; this file '( - (export () () ()) - (defmacro () () ()) - (helpfile () () ()) + (export () () ()) + (defmacro () () ()) + (helpfile () () ()) #-runtime - (evalmacros () () ()) - (module () () ()) - (autoload () () ()) - (setf () () ()) - (arraylib () () ()) - (predlib () () ()) - (assert () () ()) - (defstruct () () ()) - (listlib () () ()) - (mislib () () ()) - (numlib () () ()) - (packlib () () ()) - (seq () () ()) - (seqlib () () ()) - (iolib () () ()) - (ansi () () ()) + (evalmacros () () ()) + (module () () ()) + (autoload () () ()) + (setf () () ()) + (arraylib () () ()) + (predlib () () ()) + (assert () () ()) + (defstruct () () ()) + (listlib () () ()) + (mislib () () ()) + (numlib () () ()) + (packlib () () ()) + (seq () () ()) + (seqlib () () ()) + (iolib () () ()) + (ansi () () ()) #+old-loop - (loop () () ()) + (loop () () ()) #-old-loop - (loop2 () () ()) + (loop2 () () ()) #+cmu-format - (format () () ()) - (defpackage () () ()) - (ffi () () ()) + (format () () ()) + (defpackage () () ()) + (ffi () () ()) #-runtime - (describe () () ()) - (top () () ()) - (trace () () ()) - (config () () ()) + (describe () () ()) + (top () () ()) + (trace () () ()) + (config () () ()) #+threads - (thread () () ()) + (thread () () ()) #+nil ; This is loaded as source file - (tk-init () () ()))) + (tk-init () () ()))) (sbt:defsystem lsp diff --git a/src/lsp/describe.lsp b/src/lsp/describe.lsp index 1d25d3bf7..136bddd99 100644 --- a/src/lsp/describe.lsp +++ b/src/lsp/describe.lsp @@ -37,13 +37,13 @@ (defun select-E () (dolist (x (multiple-value-list - (multiple-value-prog1 - (eval (read-preserving-whitespace *query-io*)) - (inspect-read-line)))) - (write x - :level *old-print-level* - :length *old-print-length*) - (terpri))) + (multiple-value-prog1 + (eval (read-preserving-whitespace *query-io*)) + (inspect-read-line)))) + (write x + :level *old-print-level* + :length *old-print-length*) + (terpri))) (defun select-U () (prog1 @@ -53,7 +53,7 @@ (defun select-? () (terpri) (format t - "Inspect commands:~%~ + "Inspect commands:~%~ n (or N or Newline): inspects the field (recursively).~%~ s (or S): skips the field.~%~ p (or P): pretty-prints the field.~%~ @@ -74,68 +74,68 @@ (format t label object)) (return-from read-inspect-command nil)) (let* ((*quit-tags* (cons *quit-tag* *quit-tag*)) ;; as seen in top.lsp - (*quit-tag* *quit-tags*)) + (*quit-tag* *quit-tags*)) (declare (special *quit-tags* *quit-tags*)) (loop (when - (catch *quit-tag* ;; as seen in top.lsp - (with-simple-restart (inspect "Go back to inspector.") - (inspect-indent-1) - (if allow-recursive - (progn (princ label) - (inspect-indent) - (prin1 object)) - (format t label object)) - (write-char #\Space) ;; Inspector prompt!? - (princ " >> ") ;; This one is more suggestive. - ;;(force-output) ;; not quite enough. - (finish-output) ;; this one is stronger. - (case (do ((char (read-char *query-io*) (read-char *query-io*))) - ((and (char/= char #\Space) (char/= char #\Tab)) - (cond - ((char= char #\Newline) char) - ((char= char #\Return) char) - ((alphanumericp (peek-char)) #\!) ;; Invalid command on purpose. - (t char)) - )) - ((#\Newline #\Return) - (when allow-recursive (inspect-object object)) - (return nil)) - ((#\n #\N) - (inspect-read-line) - (when allow-recursive (inspect-object object)) - (return nil)) - ((#\s #\S) - (inspect-read-line) - (return nil)) - ((#\p #\P) - (inspect-read-line) - (select-P object)) - ((#\a #\A) - (inspect-read-line) - (throw 'ABORT-INSPECT nil)) - ((#\u #\U) - (return (values t (select-U)))) - ((#\e #\E) - (select-E)) - ((#\q #\Q) - (inspect-read-line) - (throw 'QUIT-INSPECT nil)) - ((#\?) - (inspect-read-line) - (select-?)) - (t - (inspect-read-line) - (inspect-indent) - (format t "Unknown inspector command. ~ + (catch *quit-tag* ;; as seen in top.lsp + (with-simple-restart (inspect "Go back to inspector.") + (inspect-indent-1) + (if allow-recursive + (progn (princ label) + (inspect-indent) + (prin1 object)) + (format t label object)) + (write-char #\Space) ;; Inspector prompt!? + (princ " >> ") ;; This one is more suggestive. + ;;(force-output) ;; not quite enough. + (finish-output) ;; this one is stronger. + (case (do ((char (read-char *query-io*) (read-char *query-io*))) + ((and (char/= char #\Space) (char/= char #\Tab)) + (cond + ((char= char #\Newline) char) + ((char= char #\Return) char) + ((alphanumericp (peek-char)) #\!) ;; Invalid command on purpose. + (t char)) + )) + ((#\Newline #\Return) + (when allow-recursive (inspect-object object)) + (return nil)) + ((#\n #\N) + (inspect-read-line) + (when allow-recursive (inspect-object object)) + (return nil)) + ((#\s #\S) + (inspect-read-line) + (return nil)) + ((#\p #\P) + (inspect-read-line) + (select-P object)) + ((#\a #\A) + (inspect-read-line) + (throw 'ABORT-INSPECT nil)) + ((#\u #\U) + (return (values t (select-U)))) + ((#\e #\E) + (select-E)) + ((#\q #\Q) + (inspect-read-line) + (throw 'QUIT-INSPECT nil)) + ((#\?) + (inspect-read-line) + (select-?)) + (t + (inspect-read-line) + (inspect-indent) + (format t "Unknown inspector command. ~ Type ? followed by #\\Newline for help.")) - ) - ) - nil - ) - (format t "~&Back to Inspection mode: ~ + ) + ) + nil + ) + (format t "~&Back to Inspection mode: ~ Type ? followed by #\\Newline for help.~%") - )))) + )))) #+ecl-min (defmacro inspect-recursively (label object &optional place) @@ -250,10 +250,10 @@ (inspect-recursively "imaginary part:" (imagpart number))) ((SHORT-FLOAT SINGLE-FLOAT LONG-FLOAT DOUBLE-FLOAT) (multiple-value-bind (signif expon sign) - (integer-decode-float number) - (declare (ignore sign)) - (inspect-print "exponent: ~D" expon) - (inspect-print "mantissa: ~D" signif)))))) + (integer-decode-float number) + (declare (ignore sign)) + (inspect-print "exponent: ~D" expon) + (inspect-print "mantissa: ~D" signif)))))) (defun inspect-cons (cons) (declare (si::c-local)) @@ -263,11 +263,11 @@ (l cons (cdr l))) ((atom l) (case l - ((t nil) ;; no point in inspecting recursively t nor nil. - (inspect-print (format nil "nthcdr ~D: ~~S" i) l)) - (t - (inspect-recursively (format nil "nthcdr ~D:" i) - l (cdr (nthcdr (1- i) cons)))))) + ((t nil) ;; no point in inspecting recursively t nor nil. + (inspect-print (format nil "nthcdr ~D: ~~S" i) l)) + (t + (inspect-recursively (format nil "nthcdr ~D:" i) + l (cdr (nthcdr (1- i) cons)))))) (inspect-recursively (format nil "nth ~D:" i) (car l) (nth i cons))))) @@ -315,10 +315,10 @@ (declare (si::c-local)) (incf *inspect-level*) (maphash #'(lambda (key val) - (inspect-indent-1) - (format t "key : ~S" key) - (inspect-recursively "value:" val (gethash key hashtable))) - hashtable) + (inspect-indent-1) + (format t "key : ~S" key) + (inspect-recursively "value:" val (gethash key hashtable))) + hashtable) (decf *inspect-level*)) (defun select-ht-L (hashtable) @@ -326,35 +326,35 @@ (terpri) (format t "The keys of the hash table are:~%") (maphash #'(lambda (key val) - (declare (ignore val)) - (format t " ~S~%" key)) - hashtable) + (declare (ignore val)) + (format t " ~S~%" key)) + hashtable) (terpri)) (defun select-ht-J (hashtable) (declare (si::c-local)) (let* ((key (prog1 - (read-preserving-whitespace *query-io*) - (inspect-read-line))) - (val (gethash key hashtable))) + (read-preserving-whitespace *query-io*) + (inspect-read-line))) + (val (gethash key hashtable))) (if val - (progn - (incf *inspect-level*) - (inspect-indent-1) - (format t "key : ~S" key) - (inspect-recursively "value:" val (gethash key hashtable)) - (decf *inspect-level*)) - (progn - (terpri) - (format t "The key ~S is not present or the value associated is NIL." key) - (terpri) - (terpri))))) + (progn + (incf *inspect-level*) + (inspect-indent-1) + (format t "key : ~S" key) + (inspect-recursively "value:" val (gethash key hashtable)) + (decf *inspect-level*)) + (progn + (terpri) + (format t "The key ~S is not present or the value associated is NIL." key) + (terpri) + (terpri))))) (defun select-ht-? () (declare (si::c-local)) (terpri) (format t - "Inspect commands for hash tables:~%~ + "Inspect commands for hash tables:~%~ n (or N or #\\Newline): inspects the keys/values of the hashtable (recursively).~%~ s (or S): skips the field.~%~ p (or P): pretty-prints the field.~%~ @@ -364,58 +364,58 @@ l (or L): show the keys of the hash table.~%~ j (or J) key: inspect the value associated to the key requested.~%~ q (or Q): quits the inspection.~%~ ?: prints this help message.~%~%" - )) + )) (defun inspect-hashtable (hashtable) (declare (si::c-local)) (if *inspect-mode* (progn - (decf *inspect-level*) + (decf *inspect-level*) (loop (format t "~S - hash table: " hashtable) - ;;(force-output) ;; not quite enough. - (finish-output) ;; this one is stronger. + ;;(force-output) ;; not quite enough. + (finish-output) ;; this one is stronger. (case (do ((char (read-char *query-io*) (read-char *query-io*))) - ((and (char/= char #\Space) (char/= #\Tab)) char)) - ((#\Newline #\Return) - (select-ht-N hashtable) - (return nil)) - ((#\n #\N) - (inspect-read-line) - (select-ht-N hashtable) - (return nil)) - ((#\s #\S) - (inspect-read-line) - (return nil)) - ((#\p #\P) - (inspect-read-line) - (select-P hashtable)) - ((#\a #\A) - (inspect-read-line) - (throw 'ABORT-INSPECT nil)) - ((#\e #\E) - (select-E)) - ((#\q #\Q) - (inspect-read-line) - (throw 'QUIT-INSPECT nil)) - ((#\l #\L) - (inspect-read-line) - (select-ht-L hashtable)) - ((#\j #\J) - (select-ht-J hashtable)) - ((#\?) - (inspect-read-line) - (select-ht-?))) + ((and (char/= char #\Space) (char/= #\Tab)) char)) + ((#\Newline #\Return) + (select-ht-N hashtable) + (return nil)) + ((#\n #\N) + (inspect-read-line) + (select-ht-N hashtable) + (return nil)) + ((#\s #\S) + (inspect-read-line) + (return nil)) + ((#\p #\P) + (inspect-read-line) + (select-P hashtable)) + ((#\a #\A) + (inspect-read-line) + (throw 'ABORT-INSPECT nil)) + ((#\e #\E) + (select-E)) + ((#\q #\Q) + (inspect-read-line) + (throw 'QUIT-INSPECT nil)) + ((#\l #\L) + (inspect-read-line) + (select-ht-L hashtable)) + ((#\j #\J) + (select-ht-J hashtable)) + ((#\?) + (inspect-read-line) + (select-ht-?))) (inspect-indent))) (progn - (format t "~S - hash table: " hashtable) - (maphash #'(lambda (key val) - (inspect-indent-1) - (format t "key : ~S" key) - (inspect-indent-1) - (format t "value:") - (inspect-object val)) - hashtable)))) + (format t "~S - hash table: " hashtable) + (maphash #'(lambda (key val) + (inspect-indent-1) + (format t "key : ~S" key) + (inspect-indent-1) + (format t "value:") + (inspect-object val)) + hashtable)))) #+CLOS (defun inspect-instance (instance) @@ -434,7 +434,7 @@ q (or Q): quits the inspection.~%~ (push object *inspect-history*) (catch 'ABORT-INSPECT (cond - ((symbolp object) (inspect-symbol object)) + ((symbolp object) (inspect-symbol object)) ((packagep object) (inspect-package object)) ((characterp object) (inspect-character object)) ((numberp object) (inspect-number object)) @@ -443,8 +443,8 @@ q (or Q): quits the inspection.~%~ ((vectorp object) (inspect-vector object)) ((arrayp object) (inspect-array object)) ((hash-table-p object) (inspect-hashtable object)) - #+clos - ((sys:instancep object) (inspect-instance object)) + #+clos + ((sys:instancep object) (inspect-instance object)) (t (format t "~S - ~S" object (type-of object)))))) (defun default-inspector (object) @@ -475,17 +475,17 @@ inspect commands, or type '?' to the inspector." object) (defun describe (object &optional (stream *standard-output*) - &aux (*inspect-mode* nil) + &aux (*inspect-mode* nil) (*inspect-level* 0) (*inspect-history* nil) (*print-level* nil) (*print-length* nil) - (*standard-output* (cond ((streamp stream) stream) - ((null stream) *standard-output*) - ((eq stream t) *terminal-io*) - (t (error 'type-error - :datum stream - :expected-type '(or stream t nil)))))) + (*standard-output* (cond ((streamp stream) stream) + ((null stream) *standard-output*) + ((eq stream t) *terminal-io*) + (t (error 'type-error + :datum stream + :expected-type '(or stream t nil)))))) "Args: (object &optional (stream *standard-output*)) Prints information about OBJECT to STREAM." (terpri) @@ -570,12 +570,12 @@ package whose print names contain STRING as substring. STRING may be a symbol, in which case the print-name of that symbol is used. If PACKAGE is NIL, then all packages are searched." (do* ((f nil) - (l (apropos-list string package) (cdr l))) + (l (apropos-list string package) (cdr l))) ((endp l) (format t (if f - "~&-----------------------------------------------------------------------------" - "~&No documentation for ~S in ~:[any~;~A~] package.") - string package (and package (package-name (coerce-to-package package))))) + "~&-----------------------------------------------------------------------------" + "~&No documentation for ~S in ~:[any~;~A~] package.") + string package (and package (package-name (coerce-to-package package))))) (when (print-doc (first l) t) (setf f t))) (values)) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 0953eeaa0..c42ed480f 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -41,8 +41,8 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." `(LOCALLY (DECLARE (SPECIAL ,var)) (SYS:*MAKE-SPECIAL ',var) ,@(when form-sp - `((UNLESS (BOUNDP ',var) - (SETQ ,var ,form)))) + `((UNLESS (BOUNDP ',var) + (SETQ ,var ,form)))) ,@(si::expand-set-documentation var 'variable doc-string) ,(ext:register-with-pde whole) ,(if *bytecodes-compiler* @@ -93,7 +93,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." ;; Documentation in help.lsp (multiple-value-setq (body doc-string) (remove-documentation body)) (let* ((function `#'(ext::lambda-block ,name ,vl ,@body)) - (global-function `#'(ext::lambda-block ,name ,vl + (global-function `#'(ext::lambda-block ,name ,vl (declare (si::c-global)) ,@body))) (when *dump-defun-definitions* @@ -103,7 +103,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." ,(ext:register-with-pde whole `(si::fset ',name ,global-function)) ,@(si::expand-set-documentation name 'function doc-string) ,(let ((hook *defun-inline-hook*)) - (and hook (funcall hook name global-function env))) + (and hook (funcall hook name global-function env))) ',name))) ;;; @@ -177,21 +177,21 @@ Evaluates TESTs in order until one evaluates to non-NIL. Then evaluates FORMs in order that follow the TEST and returns all values of the last FORM. If no forms follow the TEST, then returns the value of the TEST. Returns NIL, if no TESTs evaluates to non-NIL." - (dolist (l (reverse clauses) form) ; don't use nreverse here + (dolist (l (reverse clauses) form) ; don't use nreverse here (if (endp (cdr l)) - (if (eq (car l) 't) - (setq form 't) - (let ((sym (gensym))) - (setq form `(LET ((,sym ,(car l))) -; (DECLARE (:READ-ONLY ,sym)) ; Beppe - (IF ,sym ,sym ,form))))) - (if (eq (car l) 't) - (setq form (if (endp (cddr l)) - (cadr l) - `(PROGN ,@(cdr l)))) - (setq form (if (endp (cddr l)) - `(IF ,(car l) ,(cadr l) ,form) - `(IF ,(car l) (PROGN ,@(cdr l)) ,form)))))) + (if (eq (car l) 't) + (setq form 't) + (let ((sym (gensym))) + (setq form `(LET ((,sym ,(car l))) +; (DECLARE (:READ-ONLY ,sym)) ; Beppe + (IF ,sym ,sym ,form))))) + (if (eq (car l) 't) + (setq form (if (endp (cddr l)) + (cadr l) + `(PROGN ,@(cdr l)))) + (setq form (if (endp (cddr l)) + `(IF ,(car l) ,(cadr l) ,form) + `(IF ,(car l) (PROGN ,@(cdr l)) ,form)))))) ) ; program feature @@ -229,8 +229,8 @@ Evaluates FIRST-FORM and FORMs in order. Returns the value of FIRST-FORM." Evaluates FIRST-FORM, SECOND-FORM, and FORMs in order. Returns the value of SECOND-FORM." `(PROGN ,first (LET ((,sym ,second)) -; (DECLARE (:READ-ONLY ,sym)) ; Beppe - ,@body ,sym))) +; (DECLARE (:READ-ONLY ,sym)) ; Beppe + ,@body ,sym))) ; multiple values @@ -266,13 +266,13 @@ values of the last FORM. If no FORM is given, returns NIL." (defun while-until (test body jmp-op) (declare (si::c-local)) (let ((label (gensym)) - (exit (gensym))) + (exit (gensym))) `(TAGBODY (GO ,exit) ,label ,@body ,exit - (,jmp-op ,test (GO ,label))))) + (,jmp-op ,test (GO ,label))))) (defmacro sys::while (test &body body) (while-until test body 'when)) @@ -282,29 +282,29 @@ values of the last FORM. If no FORM is given, returns NIL." (defmacro case (keyform &rest clauses) (let* ((last t) - (form nil) - (key (gensym))) + (form nil) + (key (gensym))) (dolist (clause (reverse clauses) - `(LET ((,key ,keyform)) - ;;(DECLARE (:READ-ONLY ,key)) ; Beppe - ,form)) + `(LET ((,key ,keyform)) + ;;(DECLARE (:READ-ONLY ,key)) ; Beppe + ,form)) (let ((selector (car clause))) - (cond ((or (eq selector T) (eq selector 'OTHERWISE)) - (unless last - (si::signal-simple-error - 'program-error nil - "CASE: The selector ~A can only appear at the last position." - (list selector))) - (setq form `(PROGN ,@(cdr clause)))) - ((consp selector) - (setq form `(IF (MEMBER ,key ',selector) - (PROGN ,@(cdr clause)) - ,form))) - (selector - (setq form `(IF (EQL ,key ',selector) - (PROGN ,@(cdr clause)) - ,form)))) - (setq last nil))))) + (cond ((or (eq selector T) (eq selector 'OTHERWISE)) + (unless last + (si::signal-simple-error + 'program-error nil + "CASE: The selector ~A can only appear at the last position." + (list selector))) + (setq form `(PROGN ,@(cdr clause)))) + ((consp selector) + (setq form `(IF (MEMBER ,key ',selector) + (PROGN ,@(cdr clause)) + ,form))) + (selector + (setq form `(IF (EQL ,key ',selector) + (PROGN ,@(cdr clause)) + ,form)))) + (setq last nil))))) (defmacro return (&optional (val nil)) `(RETURN-FROM NIL ,val)) @@ -333,19 +333,19 @@ values of the last FORM. If no FORM is given, returns NIL." (defmacro define-symbol-macro (&whole whole symbol expansion) (cond ((not (symbolp symbol)) - (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" - symbol)) - ((specialp symbol) - (error "DEFINE-SYMBOL-MACRO: cannot redefine a special variable, ~A" - symbol)) - (t - `(eval-when (:compile-toplevel :load-toplevel :execute) - (put-sysprop ',symbol 'si::symbol-macro + (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" + symbol)) + ((specialp symbol) + (error "DEFINE-SYMBOL-MACRO: cannot redefine a special variable, ~A" + symbol)) + (t + `(eval-when (:compile-toplevel :load-toplevel :execute) + (put-sysprop ',symbol 'si::symbol-macro (lambda (form env) (declare (ignore form env)) ',expansion)) - ,(ext:register-with-pde whole) - ',symbol)))) + ,(ext:register-with-pde whole) + ',symbol)))) (defmacro nth-value (n expr) `(nth ,n (multiple-value-list ,expr))) @@ -359,8 +359,8 @@ values of the last FORM. If no FORM is given, returns NIL." ;; Quotes a form only if strictly required. This happens only when FORM is ;; either a symbol and not a keyword (if (if (atom form) - (typep form '(and symbol (not keyword) (not boolean))) - (not (eq (first form) 'quote))) + (typep form '(and symbol (not keyword) (not boolean))) + (not (eq (first form) 'quote))) (list 'quote form) form)) diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index 2ee15f17d..5eddef144 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -25,30 +25,30 @@ ;; This is needed only when bootstrapping ECL using ECL-MIN (eval-when (eval) (si::fset 'ext:register-with-pde - #'(ext::lambda-block ext:register-with-pde (whole env) - (let* ((definition (second whole)) - (output-form (third whole))) - `(if ext:*register-with-pde-hook* - (funcall ext:*register-with-pde-hook* - (copy-tree *source-location*) - ,definition - ,output-form) - ,output-form))) - t) + #'(ext::lambda-block ext:register-with-pde (whole env) + (let* ((definition (second whole)) + (output-form (third whole))) + `(if ext:*register-with-pde-hook* + (funcall ext:*register-with-pde-hook* + (copy-tree *source-location*) + ,definition + ,output-form) + ,output-form))) + t) (si::fset 'defun - #'(ext::lambda-block defun (def env) - (let* ((name (second def)) - (function `#'(ext::lambda-block ,@(cdr def)))) - (when *dump-defun-definitions* - (print function) - (setq function `(si::bc-disassemble ,function))) - (ext:register-with-pde def `(si::fset ',name ,function)))) - t) + #'(ext::lambda-block defun (def env) + (let* ((name (second def)) + (function `#'(ext::lambda-block ,@(cdr def)))) + (when *dump-defun-definitions* + (print function) + (setq function `(si::bc-disassemble ,function))) + (ext:register-with-pde def `(si::fset ',name ,function)))) + t) (si::fset 'in-package - #'(ext::lambda-block in-package (def env) - `(eval-when (eval compile load) - (si::select-package ,(string (second def))))) - t) + #'(ext::lambda-block in-package (def env) + `(eval-when (eval compile load) + (si::select-package ,(string (second def))))) + t) ) ;; @@ -57,122 +57,122 @@ ;; (let ((f #'(ext::lambda-block dolist (whole env) (declare (ignore env)) - (let (body pop finished control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) - `(block nil - (let* ((%dolist-var ,expr) - ,var) - (declare ,@declarations) - (si::while %dolist-var - (setq ,var (first %dolist-var)) - ,@body - (setq %dolist-var (cons-cdr %dolist-var))) - ,(when exit `(setq ,var nil)) - ,@exit))))))) + (let (body pop finished control var expr exit) + (setq body (rest whole)) + (when (endp body) + (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) + (setq control (first body) body (rest body)) + (when (endp control) + (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) + (setq var (first control) control (rest control)) + (if (<= 1 (length control) 2) + (setq expr (first control) exit (rest control)) + (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole)) + (multiple-value-bind (declarations body) + (process-declarations body nil) + `(block nil + (let* ((%dolist-var ,expr) + ,var) + (declare ,@declarations) + (si::while %dolist-var + (setq ,var (first %dolist-var)) + ,@body + (setq %dolist-var (cons-cdr %dolist-var))) + ,(when exit `(setq ,var nil)) + ,@exit))))))) (si::fset 'dolist f t)) (let ((f #'(ext::lambda-block dotimes (whole env) (declare (ignore env)) - (let (body pop finished control var expr exit) - (setq body (rest whole)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq control (first body) body (rest body)) - (when (endp control) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (setq var (first control) control (rest control)) - (if (<= 1 (length control) 2) - (setq expr (first control) exit (rest control)) - (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) - (multiple-value-bind (declarations body) - (process-declarations body nil) + (let (body pop finished control var expr exit) + (setq body (rest whole)) + (when (endp body) + (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) + (setq control (first body) body (rest body)) + (when (endp control) + (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) + (setq var (first control) control (rest control)) + (if (<= 1 (length control) 2) + (setq expr (first control) exit (rest control)) + (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole)) + (multiple-value-bind (declarations body) + (process-declarations body nil) (when (integerp expr) (setq declarations (cons `(type (integer 0 ,expr) ,var) declarations))) - `(block nil - (let* ((%dotimes-var ,expr) - (,var 0)) - (declare ,@declarations) - (si::while (< ,var %dotimes-var) - ,@body - (setq ,var (1+ ,var))) - ,@exit))))))) + `(block nil + (let* ((%dotimes-var ,expr) + (,var 0)) + (declare ,@declarations) + (si::while (< ,var %dotimes-var) + ,@body + (setq ,var (1+ ,var))) + ,@exit))))))) (si::fset 'dotimes f t)) (let ((f #'(ext::lambda-block do/do*-expand (whole env) (declare (ignore env)) (let (do/do* control test result vl step let psetq body) - (setq do/do* (first whole) body (rest whole)) - (if (eq do/do* 'do) - (setq let 'LET psetq 'PSETQ) - (setq let 'LET* psetq 'SETQ)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) - (setq control (first body) body (rest body)) - (when (endp body) - (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) - (setq test (first body) body (rest body)) - (when (endp test) - (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) - (setq result (rest test) test (first test)) - (dolist (c control) - (when (symbolp c) (setq c (list c))) - (case (length c) - ((1 2) - (setq vl (cons c vl))) - (3 - (setq vl (cons (butlast c) vl) - step (list* (third c) (first c) step))) - (t - (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)))) - (multiple-value-bind (declarations real-body) - (process-declarations body nil) - `(BLOCK NIL - (,let ,(nreverse vl) - (declare ,@declarations) - (sys::until ,test - ,@real-body - ,@(when step (list (cons psetq (nreverse step))))) - ,@(or result '(nil))))))))) + (setq do/do* (first whole) body (rest whole)) + (if (eq do/do* 'do) + (setq let 'LET psetq 'PSETQ) + (setq let 'LET* psetq 'SETQ)) + (when (endp body) + (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) + (setq control (first body) body (rest body)) + (when (endp body) + (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) + (setq test (first body) body (rest body)) + (when (endp test) + (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)) + (setq result (rest test) test (first test)) + (dolist (c control) + (when (symbolp c) (setq c (list c))) + (case (length c) + ((1 2) + (setq vl (cons c vl))) + (3 + (setq vl (cons (butlast c) vl) + step (list* (third c) (first c) step))) + (t + (simple-program-error "Syntax error in ~A:~%~A" do/do* whole)))) + (multiple-value-bind (declarations real-body) + (process-declarations body nil) + `(BLOCK NIL + (,let ,(nreverse vl) + (declare ,@declarations) + (sys::until ,test + ,@real-body + ,@(when step (list (cons psetq (nreverse step))))) + ,@(or result '(nil))))))))) (si::fset 'do f t) (si::fset 'do* f t)) (defun eval-feature (x &aux operator) (declare (si::c-local)) (cond ((symbolp x) - (and (member x *features* :test #'eq) t)) - ((atom x) (error "~ is not allowed as a feature" x)) - ((not (symbolp (setq operator (first x)))) - (error "~S is not a valid feature expression." x)) + (and (member x *features* :test #'eq) t)) + ((atom x) (error "~ is not allowed as a feature" x)) + ((not (symbolp (setq operator (first x)))) + (error "~S is not a valid feature expression." x)) ((eql operator :AND) (dolist (x (cdr x) t) (when (not (eval-feature x)) (return nil)))) ((eql operator :OR) (dolist (x (cdr x) nil) (when (eval-feature x) (return t)))) ((eql operator :NOT) - (not (eval-feature (second x)))) - (t (error "~S is not a valid feature expression." x)))) + (not (eval-feature (second x)))) + (t (error "~S is not a valid feature expression." x)))) (defun do-read-feature (stream subchar arg test) (declare (si::c-local)) (when arg (error "Reading from ~S: no number should appear between # and ~A" - stream subchar)) + stream subchar)) (let ((feature (let ((*package* (find-package "KEYWORD"))) - (read stream t nil t)))) + (read stream t nil t)))) (if (and (not *read-suppress*) (eq (eval-feature feature) test)) - (read stream t nil t) - (let ((*read-suppress* t)) (read stream t nil t) (values))))) + (read stream t nil t) + (let ((*read-suppress* t)) (read stream t nil t) (values))))) (defun sharp-+-reader (stream subchar arg) (do-read-feature stream subchar arg T)) diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 9c7834af5..96102f563 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -9,7 +9,7 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; FFI Symbols used in the foreign function interface +;;;; FFI Symbols used in the foreign function interface (in-package "FFI") @@ -58,57 +58,57 @@ (defun size-of-foreign-type (name) (let* ((size 0) align - (type (%convert-to-ffi-type name))) + (type (%convert-to-ffi-type name))) (unless type (error "Incomplete or unknown foreign type ~A" name)) (cond ((symbolp type) - (setf size (si:size-of-foreign-elt-type type) + (setf size (si:size-of-foreign-elt-type type) align (si:alignment-of-foreign-elt-type type))) - ((atom type) - (error "~A is not a valid foreign type identifier" name)) - ((eq (setf name (first type)) :struct) - (setf size (slot-position type nil) + ((atom type) + (error "~A is not a valid foreign type identifier" name)) + ((eq (setf name (first type)) :struct) + (setf size (slot-position type nil) align (apply #'max (mapcar #'(lambda (field) - (multiple-value-bind (field-size field-align) + (multiple-value-bind (field-size field-align) (size-of-foreign-type (second field)) - (declare (ignore field-size)) - field-align)) - (rest type)))) - (%align-data size align)) - ((eq name :array) - (unless (and (setf size (third type)) (realp size)) - (error "Incomplete foreign type: ~S" type)) - (multiple-value-bind (elt-size elt-align) - (size-of-foreign-type (second type)) - (setf size (* size elt-size) + (declare (ignore field-size)) + field-align)) + (rest type)))) + (%align-data size align)) + ((eq name :array) + (unless (and (setf size (third type)) (realp size)) + (error "Incomplete foreign type: ~S" type)) + (multiple-value-bind (elt-size elt-align) + (size-of-foreign-type (second type)) + (setf size (* size elt-size) align elt-align))) - ((eq name :union) - (dolist (field (rest type)) - (multiple-value-bind (field-size field-align) - (size-of-foreign-type (second field)) - (when (> field-size size) - (setf size field-size)) - (when (or (null align) (> field-align align)) - (setf align field-align))))) - ((eq name '*) - (setf size (si:size-of-foreign-elt-type :pointer-void) + ((eq name :union) + (dolist (field (rest type)) + (multiple-value-bind (field-size field-align) + (size-of-foreign-type (second field)) + (when (> field-size size) + (setf size field-size)) + (when (or (null align) (> field-align align)) + (setf align field-align))))) + ((eq name '*) + (setf size (si:size-of-foreign-elt-type :pointer-void) align (si:alignment-of-foreign-elt-type :pointer-void))) ((eq name 'quote) (return-from size-of-foreign-type (size-of-foreign-type (second type)))) - (t - (error "~A does not denote a foreign type" name))) + (t + (error "~A does not denote a foreign type" name))) (values size (or align 0)))) (defun allocate-foreign-object (type &optional (size 0 size-flag)) (let ((type-size (size-of-foreign-type type))) (cond ((null size-flag) - (si::allocate-foreign-data type type-size)) - ((and (typep size 'fixnum) (>= size 0)) - (let ((bytes (* size type-size))) - (si::allocate-foreign-data `(:array ,type ,size) bytes))) - (t - (error "~A is not a valid array dimension size" size))))) + (si::allocate-foreign-data type type-size)) + ((and (typep size 'fixnum) (>= size 0)) + (let ((bytes (* size type-size))) + (si::allocate-foreign-data `(:array ,type ,size) bytes))) + (t + (error "~A is not a valid array dimension size" size))))) (defun free-foreign-object (ptr) (si::free-foreign-data ptr)) @@ -119,28 +119,28 @@ (defmacro def-enum (name values-list &key (separator-string "#")) (let ((constants '()) - (value -1) - field - forms) + (value -1) + field + forms) (setf #| name (string name) |# - separator-string (string separator-string)) + separator-string (string separator-string)) (dolist (item values-list) (cond ((symbolp item) - (setf field item) - (incf value)) - ((and (consp item) - (symbolp (setf field (first item))) - (integerp (setf value (second item))) - (endp (cddr item)))) - (t - (error "Not a valid argument to DEF-ENUM~%~a" values-list))) + (setf field item) + (incf value)) + ((and (consp item) + (symbolp (setf field (first item))) + (integerp (setf value (second item))) + (endp (cddr item)))) + (t + (error "Not a valid argument to DEF-ENUM~%~a" values-list))) (setf field (concatenate 'string - (symbol-name name) - separator-string - (string field))) + (symbol-name name) + separator-string + (string field))) (push `(defconstant ,(intern field (symbol-package name)) - ',value) - forms)) + ',value) + forms)) `(progn (def-foreign-type ,name :int) ,@forms))) @@ -151,45 +151,45 @@ ;;; ;;; The structure type is represented by the following list: ;;; -;;; (STRUCT (SLOT-NAME1 . SLOT-TYPE1)*) +;;; (STRUCT (SLOT-NAME1 . SLOT-TYPE1)*) ;;; ;;; FIXME! We do not care about slot alignment! ;;; (defmacro def-struct (name &rest slots) (let ((struct-type (list :struct)) - field - type) + field + type) (dolist (item (subst `(* ,name) :pointer-self slots)) (if (and (consp item) - (= (length item) 2) - (symbolp (setf field (first item)))) - (setf type (second item)) - (error "Not a valid DEF-STRUCT slot ~A" item)) + (= (length item) 2) + (symbolp (setf field (first item)))) + (setf type (second item)) + (error "Not a valid DEF-STRUCT slot ~A" item)) (push (list field type) struct-type)) `(def-foreign-type ,name ,(nreverse struct-type)))) (defun slot-position (type field) (setf type (%convert-to-ffi-type type)) (let ((ndx 0) - (is-union nil)) + (is-union nil)) (cond ((atom type) - (error "~A is not a foreign STRUCT or UNION type" type)) - ((eq (first type) :struct)) - ((eq (first type) :union) - (setf is-union t)) - (t - (error "~A is not a foreign STRUCT or UNION type" type))) + (error "~A is not a foreign STRUCT or UNION type" type)) + ((eq (first type) :struct)) + ((eq (first type) :union) + (setf is-union t)) + (t + (error "~A is not a foreign STRUCT or UNION type" type))) (dolist (slot (rest type)) (let* ((slot-name (car slot)) - (slot-type (cadr slot))) - (multiple-value-bind (slot-size slot-align) - (size-of-foreign-type slot-type) - (%align-data ndx slot-align) - (when (eq slot-name field) - (return-from slot-position (values ndx slot-type slot-size))) - (unless is-union - (incf ndx slot-size))))) + (slot-type (cadr slot))) + (multiple-value-bind (slot-size slot-align) + (size-of-foreign-type slot-type) + (%align-data ndx slot-align) + (when (eq slot-name field) + (return-from slot-position (values ndx slot-type slot-size))) + (unless is-union + (incf ndx slot-size))))) (values ndx nil nil))) (defun get-slot-value (object struct-type field) @@ -224,46 +224,46 @@ (defun deref-array (array array-type position) (setf array-type (%convert-to-ffi-type array-type)) (let* ((element-type (second array-type)) - (element-size (size-of-foreign-type element-type)) - (ndx (* position element-size)) - (length (or (third array-type) '*))) + (element-size (size-of-foreign-type element-type)) + (ndx (* position element-size)) + (length (or (third array-type) '*))) (unless (or (eq length '*) - (> length position -1)) + (> length position -1)) (error "Out of bounds when accessing array ~A." array)) (%foreign-data-ref (si::foreign-data-recast array (+ ndx element-size) array-type) ndx element-type element-size))) (defun (setf deref-array) (value array array-type position) (setf array-type (%convert-to-ffi-type array-type)) (let* ((element-type (second array-type)) - (element-size (size-of-foreign-type element-type)) - (ndx (* position element-size)) - (length (or (third array-type) '*))) + (element-size (size-of-foreign-type element-type)) + (ndx (* position element-size)) + (length (or (third array-type) '*))) (unless (or (eq length '*) - (> length position -1)) + (> length position -1)) (error "Out of bounds when accessing array ~A." array)) (%foreign-data-set (si::foreign-data-recast array (+ ndx element-size) array-type) ndx element-type value))) (defun %foreign-data-set (obj ndx type value) (cond ((foreign-elt-type-p type) (si::foreign-data-set-elt obj ndx type value)) - ((atom type) - (error "Unknown foreign primitive type: ~A" type)) - ((eq (first type) '*) - (si::foreign-data-set-elt obj ndx :pointer-void value)) - (t - (si::foreign-data-set obj ndx value)))) + ((atom type) + (error "Unknown foreign primitive type: ~A" type)) + ((eq (first type) '*) + (si::foreign-data-set-elt obj ndx :pointer-void value)) + (t + (si::foreign-data-set obj ndx value)))) (defun %foreign-data-ref (obj ndx type &optional (size 0 size-p)) (cond ((foreign-elt-type-p type) (si::foreign-data-ref-elt obj ndx type)) - ((atom type) - (error "Unknown foreign primitive type: ~A" type)) - ((eq (first type) '*) - (si::foreign-data-recast (si::foreign-data-ref-elt obj ndx :pointer-void) - (size-of-foreign-type (second type)) - type)) - (t - (si::foreign-data-ref obj ndx (if size-p size (size-of-foreign-type type)) type)))) + ((atom type) + (error "Unknown foreign primitive type: ~A" type)) + ((eq (first type) '*) + (si::foreign-data-recast (si::foreign-data-ref-elt obj ndx :pointer-void) + (size-of-foreign-type (second type)) + type)) + (t + (si::foreign-data-ref obj ndx (if size-p size (size-of-foreign-type type)) type)))) ;;;---------------------------------------------------------------------- ;;; UNIONS @@ -271,13 +271,13 @@ (defmacro def-union (name &rest slots) (let ((struct-type (list :union)) - field - type) + field + type) (dolist (item (subst `(* ,struct-type) :pointer-self slots)) (unless (and (consp item) - (= (length item) 2) - (symbolp (setf field (first item)))) - (error "Not a valid DEF-UNION slot ~A" item)) + (= (length item) 2) + (symbolp (setf field (first item)))) + (error "Not a valid DEF-UNION slot ~A" item)) (setf type (second item)) (push (list field type) struct-type)) `(def-foreign-type ,name ,(nreverse struct-type)))) @@ -296,14 +296,14 @@ (setf type (%convert-to-ffi-type type)) (cond ((foreign-elt-type-p type) (si::foreign-data-ref-elt ptr 0 type)) - ((atom type) - (error "Unknown foreign primitive type: ~A" type)) - ((eq (first type) '*) - (si::foreign-data-recast (si::foreign-data-ref-elt ptr 0 :pointer-void) - (size-of-foreign-type (second type)) - (second type))) - (t - (error "Cannot dereference pointer to foreign data, ~A" ptr)) + ((atom type) + (error "Unknown foreign primitive type: ~A" type)) + ((eq (first type) '*) + (si::foreign-data-recast (si::foreign-data-ref-elt ptr 0 :pointer-void) + (size-of-foreign-type (second type)) + (second type))) + (t + (error "Cannot dereference pointer to foreign data, ~A" ptr)) )) (defun (setf deref-pointer) (value ptr type) @@ -320,8 +320,8 @@ (defun make-pointer (addr type) (c-inline (type (size-of-foreign-type type) addr) (:object :unsigned-long :unsigned-long) :object "ecl_make_foreign_data(#0, #1, (void*)#2)" - :side-effects t - :one-liner t)) + :side-effects t + :one-liner t)) #+(OR) ;; Already defined in core (defun null-pointer-p (object) @@ -339,13 +339,13 @@ (defun ensure-char-character (char) (cond ((characterp char) char) - ((integerp char) (code-char char)) - (t (error "~a cannot be coerced to type CHARACTER" char)))) + ((integerp char) (code-char char)) + (t (error "~a cannot be coerced to type CHARACTER" char)))) (defun ensure-char-integer (char) (cond ((characterp char) (char-code char)) - ((integerp char) char) - (t (error "~a cannot be coerced to type INTEGER" char)))) + ((integerp char) char) + (t (error "~a cannot be coerced to type INTEGER" char)))) (defun ensure-char-storable (char) char) @@ -377,23 +377,23 @@ (defun foreign-string-length (foreign-string) (c-inline (foreign-string) (t) :int - "strlen((#0)->foreign.data)" - :side-effects nil - :one-liner t)) + "strlen((#0)->foreign.data)" + :side-effects nil + :one-liner t)) (defun convert-from-foreign-string (foreign-string - &key length (null-terminated-p t)) + &key length (null-terminated-p t)) (cond ((and (not length) null-terminated-p) - (setf length (foreign-string-length foreign-string))) - ((not (integerp length)) - (error "~A is not a valid string length" length))) + (setf length (foreign-string-length foreign-string))) + ((not (integerp length)) + (error "~A is not a valid string length" length))) (c-inline (foreign-string length) (t fixnum) string "{ - cl_index length = #1; - cl_object output = ecl_alloc_simple_base_string(length); - memcpy(output->base_string.self, (#0)->foreign.data, length); - @(return) = output; - }" + cl_index length = #1; + cl_object output = ecl_alloc_simple_base_string(length); + memcpy(output->base_string.self, (#0)->foreign.data, length); + @(return) = output; + }" :one-liner nil :side-effects t)) @@ -401,20 +401,20 @@ (let ((lisp-string (string string-designator))) (c-inline (lisp-string) (t) t "{ - cl_object lisp_string = #0; - cl_index size = lisp_string->base_string.fillp; - cl_object output = ecl_allocate_foreign_data(@(* :char), size+1); - memcpy(output->foreign.data, lisp_string->base_string.self, size); - output->foreign.data[size] = '\\0'; - @(return) = output; - }" - :one-liner nil - :side-effects t) + cl_object lisp_string = #0; + cl_index size = lisp_string->base_string.fillp; + cl_object output = ecl_allocate_foreign_data(@(* :char), size+1); + memcpy(output->foreign.data, lisp_string->base_string.self, size); + output->foreign.data[size] = '\\0'; + @(return) = output; + }" + :one-liner nil + :side-effects t) )) (defun allocate-foreign-string (size &key unsigned) (si::allocate-foreign-data `(* ,(if unsigned :unsigned-char :char)) - (1+ size))) + (1+ size))) (defmacro with-foreign-string ((foreign-string lisp-string) &rest body) (let ((result (gensym))) @@ -437,7 +437,7 @@ (defmacro with-foreign-object ((var type) &body body) `(let ((,var (allocate-foreign-object ,type))) (unwind-protect - (progn ,@body) + (progn ,@body) (free-foreign-object ,var)))) (defmacro with-foreign-objects (bindings &rest body) @@ -451,15 +451,15 @@ (let (binding-name ptr type) (case (length bind) (2 (setf binding-name (first bind) - ptr binding-name - type (second bind))) + ptr binding-name + type (second bind))) (3 (setf binding-name (first bind) - ptr (second bind) - type (third bind))) + ptr (second bind) + type (third bind))) (otherwise (error "Arguments missing in WITH-CAST-POINTER"))) `(let ((,binding-name (si::foreign-data-pointer (si::foreign-data-recast ,ptr (size-of-foreign-type ',type) :void) 0 - (size-of-foreign-type ',type) - ',type))) + (size-of-foreign-type ',type) + ',type))) ,@body))) ;;;---------------------------------------------------------------------- @@ -469,41 +469,41 @@ (defun lisp-to-c-name (name) (cond ((or (stringp name) (symbolp name)) - (values name (intern (string-upcase (substitute #\- #\_ (string name)))))) - ((and (consp name) - (= (length name) 2)) - (values (first name) (second name))))) + (values name (intern (string-upcase (substitute #\- #\_ (string name)))))) + ((and (consp name) + (= (length name) 2)) + (values (first name) (second name))))) (defun %convert-to-arg-type (type) (let ((type (%convert-to-ffi-type type))) (cond ((atom type) type) ((eq (first type) '*) :pointer-void) - ((eq (first type) :array) :pointer-void) - (t (error "Unsupported argument type: ~A" type)) + ((eq (first type) :array) :pointer-void) + (t (error "Unsupported argument type: ~A" type)) ))) (defun %convert-to-return-type (type) (let ((type (%convert-to-ffi-type type))) (cond ((atom type) type) ((eq (first type) '*) (second type)) - (t type)))) + (t type)))) (defun produce-function-call (c-name nargs) (declare (si::c-local)) (format nil "~a(~a)" c-name - (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z" - 0 (max 0 (1- (* nargs 3)))))) + (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z" + 0 (max 0 (1- (* nargs 3)))))) ;;; FIXME! We should turn this into a closure generator that produces no code. #+DFFI (defmacro def-lib-function (name args &key returning module (call :cdecl)) (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((return-type (ffi::%convert-to-return-type returning)) - (return-required (not (eq return-type :void))) - (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args))) + (return-required (not (eq return-type :void))) + (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args))) `(let ((c-fun (si::find-foreign-symbol ',c-name ,module :pointer-void 0))) - (defun ,lisp-name ,(mapcar #'first args) - (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)) ,call)))))) + (defun ,lisp-name ,(mapcar #'first args) + (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)) ,call)))))) (defmacro def-function (name args &key module (returning :void) (call :cdecl)) #+DFFI @@ -513,26 +513,26 @@ (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((arguments (mapcar #'first args)) - (arg-types (mapcar #'(lambda (type) (%convert-to-arg-type (second type))) args)) - (return-type (%convert-to-return-type returning)) - (nargs (length arguments)) - (c-string (produce-function-call c-name nargs)) - (casting-required (not (or (member return-type '(:void :cstring)) - (foreign-elt-type-p return-type)))) - (inline-form `(c-inline ,arguments ,arg-types - ,(if casting-required :pointer-void return-type) - ,c-string - :one-liner t - :side-effects t))) + (arg-types (mapcar #'(lambda (type) (%convert-to-arg-type (second type))) args)) + (return-type (%convert-to-return-type returning)) + (nargs (length arguments)) + (c-string (produce-function-call c-name nargs)) + (casting-required (not (or (member return-type '(:void :cstring)) + (foreign-elt-type-p return-type)))) + (inline-form `(c-inline ,arguments ,arg-types + ,(if casting-required :pointer-void return-type) + ,c-string + :one-liner t + :side-effects t))) (when casting-required - (setf inline-form - `(si::foreign-data-recast ,inline-form - (size-of-foreign-type ',return-type) - ',return-type))) + (setf inline-form + `(si::foreign-data-recast ,inline-form + (size-of-foreign-type ',return-type) + ',return-type))) (when (> nargs 36) - (error "FFI can only handle C functions with up to 36 arguments")) + (error "FFI can only handle C functions with up to 36 arguments")) `(defun ,lisp-name (,@arguments) - ,inline-form) + ,inline-form) ))) (defmacro def-foreign-var (name type module) @@ -543,14 +543,14 @@ (can-deref (or (foreign-elt-type-p ffi-type) (and (consp ffi-type) (member (first ffi-type) '(* :array))))) - (inline-form (cond #+dffi + (inline-form (cond #+dffi ((and module *use-dffi*) - `(si::find-foreign-symbol ,c-name ,module ',type ,(size-of-foreign-type type))) - (t - `(c-inline () () :object - ,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)" - type (size-of-foreign-type type) c-name) - :side-effects t :one-liner t))))) + `(si::find-foreign-symbol ,c-name ,module ',type ,(size-of-foreign-type type))) + (t + `(c-inline () () :object + ,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)" + type (size-of-foreign-type type) c-name) + :side-effects t :one-liner t))))) (if can-deref `(progn (put-sysprop ',lisp-name 'ffi-foreign-var ,inline-form) @@ -582,17 +582,17 @@ (dolist (p directories) (dolist (n names) (dolist (e types) - (let ((full-path (probe-file (make-pathname - :device d - :directory (etypecase p - (pathname (pathname-directory p)) - (string (pathname-directory (parse-namestring p))) - (list p)) - :name n - :type e)))) - (when full-path - (return-from find-foreign-library full-path)) - ))))) + (let ((full-path (probe-file (make-pathname + :device d + :directory (etypecase p + (pathname (pathname-directory p)) + (string (pathname-directory (parse-namestring p))) + (list p)) + :name n + :type e)))) + (when full-path + (return-from find-foreign-library full-path)) + ))))) nil) (defparameter +loaded-libraries+ nil) @@ -604,27 +604,27 @@ (filename (namestring path)) (pack (find-package "COMPILER")) (flag (if system-library - (concatenate 'string "-l" tmp) - filename))) + (concatenate 'string "-l" tmp) + filename))) (unless (find filename ffi::+loaded-libraries+ :test #'string-equal) (setf (symbol-value (intern "*LD-FLAGS*" pack)) - (concatenate 'string (symbol-value (intern "*LD-FLAGS*" pack)) " " flag)) + (concatenate 'string (symbol-value (intern "*LD-FLAGS*" pack)) " " flag)) (setf (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) - (concatenate 'string (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) - " " flag)) + (concatenate 'string (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) + " " flag)) (setf (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) - (concatenate 'string (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) - " " flag)) + (concatenate 'string (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) + " " flag)) (push filename ffi::+loaded-libraries+)) t)) (defmacro load-foreign-library (filename &key module supporting-libraries force-load - system-library &environment env) + system-library &environment env) (declare (ignore module force-load supporting-libraries)) (let ((compile-form (and (constantp filename env) `((eval-when (:compile-toplevel) (do-load-foreign-library ,filename - ,(ext:constant-form-value system-library)))))) + ,(ext:constant-form-value system-library)))))) (dyn-form #+dffi (when (and (not system-library) *use-dffi*) `((si:load-foreign-module ,filename))) #-dffi nil)) @@ -663,7 +663,7 @@ (defun clines (&rest args) (error "The special form clines cannot be used in the interpreter: ~A" - args)) + args)) (eval-when (:load-toplevel :execute) (defmacro c-inline (args arg-types ret-type &body others) @@ -683,7 +683,7 @@ the actual arguments are of the specified type." ;; defCbody must go first, because it clears symbol-plist of fun (defCbody ,fun ,arg-types ,type ,code) (declaim (ftype (function ,arg-types ,type) ,fun)) - (c::def-inline ,fun :always ,arg-types ,type ,code))) + (c::def-inline ,fun :always ,arg-types ,type ,code))) (defmacro defla (&rest body) "Syntax: (defla name lambda-list &body body)" " @@ -704,7 +704,7 @@ defined Lisp function and VALUE-TYPE is its the return type." (let ((args (mapcar #'(lambda (x) (gensym)) arg-types))) `(defun ,name ,args (c-inline ,args ,arg-types ,result-type - ,C-expr :one-liner t)))) + ,C-expr :one-liner t)))) (defmacro defentry (name arg-types c-name &key no-interrupts) "Syntax: (defentry symbol (&rest arg-types*) (result-type function-name)) @@ -715,19 +715,19 @@ interpreter ignores this form. ARG-TYPEs are argument types of the C function and VALUE-TYPE is the return type of the C function. Symbols OBJECT, INT, CHAR, CHAR*, FLOAT, DOUBLE are allowed for these types." (let ((output-type :object) - (args (mapcar #'(lambda (x) (gensym)) arg-types))) + (args (mapcar #'(lambda (x) (gensym)) arg-types))) (if (consp c-name) - (setf output-type (first c-name) - c-name (second c-name))) + (setf output-type (first c-name) + c-name (second c-name))) (let* ((call (produce-function-call (string c-name) (length arg-types))) - (full-text (if no-interrupts - (concatenate 'string - "ecl_disable_interrupts();@(return)=" - call - ";ecl_enable_interrupts();") - call))) + (full-text (if no-interrupts + (concatenate 'string + "ecl_disable_interrupts();@(return)=" + call + ";ecl_enable_interrupts();") + call))) `(defun ,name ,args - (c-inline ,args ,arg-types ,output-type - ,full-text - :one-liner ,(not no-interrupts)))))) + (c-inline ,args ,arg-types ,output-type + ,full-text + :one-liner ,(not no-interrupts)))))) diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp index 67b5b79c5..08b8fe3ab 100644 --- a/src/lsp/format.lsp +++ b/src/lsp/format.lsp @@ -202,91 +202,91 @@ (defun scale-exponent (original-x) (declare (optimize (debug 0) (safety 0))) (let* ((x (coerce original-x 'long-float)) - (delta 0)) + (delta 0)) (declare (long-float x) - (fixnum delta)) + (fixnum delta)) (multiple-value-bind (sig exponent) - (decode-float x) + (decode-float x) (declare (ignore sig) - (fixnum exponent) - (long-float sig)) + (fixnum exponent) + (long-float sig)) (when (zerop x) - (return-from scale-exponent (values (float 0.0l0 original-x) 1))) + (return-from scale-exponent (values (float 0.0l0 original-x) 1))) ;; When computing our initial scale factor using EXPT, we pull out part of ;; the computation to avoid over/under flow. When denormalized, we must pull ;; out a large factor, since there is more negative exponent range than ;; positive range. (when (and (minusp exponent) - (< least-negative-normalized-long-float x - least-positive-normalized-long-float)) - #+long-float - (setf x (* x 1.0l18) delta -18) - #-long-float - (setf x (* x 1.0l16) delta -16)) + (< least-negative-normalized-long-float x + least-positive-normalized-long-float)) + #+long-float + (setf x (* x 1.0l18) delta -18) + #-long-float + (setf x (* x 1.0l16) delta -16)) ;; We find the appropriate factor that keeps the output within [0.1,1) ;; Note that we have to compute the exponential _every_ _time_ in the loop ;; because multiplying just by 10.0l0 every time would lead to a greater ;; loss of precission. (let ((ex (round (* exponent #.(log 2l0 10))))) - (declare (fixnum ex)) - (if (minusp ex) - (loop for y of-type long-float - = (* x (the long-float (expt 10.0l0 (- ex)))) - while (< y 0.1l0) - do (decf ex) - finally (return (values y (the fixnum (+ delta ex))))) - (loop for y of-type long-float - = (/ x (the long-float (expt 10.0l0 ex))) - while (>= y 1.0l0) - do (incf ex) - finally (return (values y (the fixnum (+ delta ex))))))) + (declare (fixnum ex)) + (if (minusp ex) + (loop for y of-type long-float + = (* x (the long-float (expt 10.0l0 (- ex)))) + while (< y 0.1l0) + do (decf ex) + finally (return (values y (the fixnum (+ delta ex))))) + (loop for y of-type long-float + = (/ x (the long-float (expt 10.0l0 ex))) + while (>= y 1.0l0) + do (incf ex) + finally (return (values y (the fixnum (+ delta ex))))))) #+(or) (loop with ex of-type fixnum - = (round (* exponent #.(log 2l0 10))) - for y of-type long-float - = (if (minusp ex) - (* x (the long-float (expt 10.0l0 (- ex)))) - (/ x (the long-float (expt 10.0l0 ex)))) - do (cond ((<= y 0.1l0) - (decf ex)) - ((> y 1.0l0) - (incf ex)) - (t - (return (values y (the fixnum (+ delta ex)))))))))) + = (round (* exponent #.(log 2l0 10))) + for y of-type long-float + = (if (minusp ex) + (* x (the long-float (expt 10.0l0 (- ex)))) + (/ x (the long-float (expt 10.0l0 ex)))) + do (cond ((<= y 0.1l0) + (decf ex)) + ((> y 1.0l0) + (incf ex)) + (t + (return (values y (the fixnum (+ delta ex)))))))))) #+(or) (defun scale-exponent (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) - (decode-float x) + (decode-float x) (declare (ignore sig)) (if (= x 0.0l0) - (values (float 0.0l0 original-x) 1) - (let* ((ex (round (* exponent (log 2l0 10)))) - (x (if (minusp ex) - (if #-ecl(float-denormalized-p x) - #+ecl(< least-negative-normalized-long-float - x - least-positive-normalized-long-float) - #-long-float - (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) - #+long-float - (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) - (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) - (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) - (do ((d 10.0l0 (* d 10.0l0)) - (y x (/ x d)) - (ex ex (1+ ex))) - ((< y 1.0l0) - (do ((m 10.0l0 (* m 10.0l0)) - (z y (* y m)) - (ex ex (1- ex))) - ((>= z 0.1l0) - (values (float z original-x) ex)))))))))) + (values (float 0.0l0 original-x) 1) + (let* ((ex (round (* exponent (log 2l0 10)))) + (x (if (minusp ex) + (if #-ecl(float-denormalized-p x) + #+ecl(< least-negative-normalized-long-float + x + least-positive-normalized-long-float) + #-long-float + (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + #+long-float + (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) + (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) + (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) + (do ((d 10.0l0 (* d 10.0l0)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y 1.0l0) + (do ((m 10.0l0 (* m 10.0l0)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= z 0.1l0) + (values (float z original-x) ex)))))))))) (defstruct (format-directive - #-ecl(:print-function %print-format-directive) - #+ecl :named - #+ecl(:type vector)) + #-ecl(:print-function %print-format-directive) + #+ecl :named + #+ecl(:type vector)) (string t :type simple-string) (start 0 :type (and unsigned-byte fixnum)) (end 0 :type (and unsigned-byte fixnum)) @@ -302,8 +302,8 @@ (declare (ignore depth)) (print-unreadable-object (struct stream) (write-string (format-directive-string struct) stream - :start (format-directive-start struct) - :end (format-directive-end struct)))) + :start (format-directive-start struct) + :end (format-directive-end struct)))) #+formatter (defparameter *format-directive-expanders* @@ -326,110 +326,110 @@ (defun tokenize-control-string (string) (declare (simple-string string) - (si::c-local)) + (si::c-local)) (let ((index 0) - (end (length string)) - (result nil)) + (end (length string)) + (result nil)) (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))) - (push directive result) - (setf index (format-directive-end directive))))) + (when (> next-directive index) + (push (subseq string index next-directive) result)) + (when (= next-directive end) + (return)) + (let ((directive (parse-directive string next-directive))) + (push directive result) + (setf index (format-directive-end directive))))) (nreverse result))) (defun parse-directive (string start) (declare (simple-string string) - (si::c-local)) + (si::c-local)) (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)))) + (if (= posn end) + (error 'format-error + :complaint "String ended before directive was found." + :control-string string + :offset start) + (schar string posn)))) (loop - (let ((char (get-char))) - (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) - (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)) - (push (cons posn :arg) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\#) - (push (cons posn :remaining) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\') - (incf posn) - (push (cons posn (get-char)) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\,) - (push (cons posn nil) params)) - ((char= char #\:) - (if colonp - (error 'format-error - :complaint "Too many colons supplied." - :control-string string - :offset posn) - (setf colonp t))) - ((char= char #\@) - (if atsignp - (error 'format-error - :complaint "Too many at-signs supplied." - :control-string string - :offset posn) - (setf atsignp t))) - (t - (when (char= (schar string (1- posn)) #\,) - (push (cons (1- posn) nil) params)) - (return)))) - (incf posn)) + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (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)) + (push (cons posn :arg) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (push (cons posn :remaining) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (incf posn) + (push (cons posn (get-char)) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\,) + (push (cons posn nil) params)) + ((char= char #\:) + (if colonp + (error 'format-error + :complaint "Too many colons supplied." + :control-string string + :offset posn) + (setf colonp t))) + ((char= char #\@) + (if atsignp + (error 'format-error + :complaint "Too many at-signs supplied." + :control-string string + :offset posn) + (setf atsignp t))) + (t + (when (char= (schar string (1- posn)) #\,) + (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)))))) ;;;; Specials used to communicate information. @@ -528,44 +528,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)))) - (*output-layout-mode* nil) - (*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)))) + (*output-layout-mode* nil) + (*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) (declare (si::c-local)) (if directives (let ((directive (car directives))) - (etypecase directive - (simple-string - (write-string directive stream) - (interpret-directive-list stream (cdr directives) orig-args args)) - (#-ecl format-directive #+ecl vector - (multiple-value-bind - (new-directives new-args) - (let ((function - (svref *format-directive-interpreters* - (char-code (format-directive-character - directive)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (unless function - (error 'format-error - :complaint "Unknown format directive.")) - (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))))) + (etypecase directive + (simple-string + (write-string directive stream) + (interpret-directive-list stream (cdr directives) orig-args args)) + (#-ecl format-directive #+ecl vector + (multiple-value-bind + (new-directives new-args) + (let ((function + (svref *format-directive-interpreters* + (char-code (format-directive-character + directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (unless function + (error 'format-error + :complaint "Unknown format directive.")) + (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)) @@ -581,53 +581,53 @@ (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) (declare (si::c-local)) (let* ((string (etypecase string - (simple-string - string) - (string - (coerce string 'simple-string)))) - (*output-layout-mode* nil) - (*default-format-error-control-string* string) - (directives (tokenize-control-string string))) + (simple-string + string) + (string + (coerce string 'simple-string)))) + (*output-layout-mode* nil) + (*default-format-error-control-string* string) + (directives (tokenize-control-string string))) `(block nil ,@(expand-directive-list directives)))) (defun expand-directive-list (directives) (declare (si::c-local)) (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))) + (form 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) @@ -635,28 +635,28 @@ (etypecase directive (simple-string (values `(write-string ,directive stream) - more-directives)) + more-directives)) (format-directive (let ((expander - (aref *format-directive-expanders* - (char-code (format-directive-character directive)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) + (aref *format-directive-expanders* + (char-code (format-directive-character directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) (if expander - (funcall expander directive more-directives) - (error 'format-error - :complaint "Unknown directive.")))))) + (funcall expander directive more-directives) + (error 'format-error + :complaint "Unknown directive.")))))) (defun expand-next-arg (&optional offset) (declare (si::c-local)) (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))) (defun need-hairy-args () (declare (si::c-local)) @@ -670,17 +670,17 @@ `(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))) (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))) );#+formatter @@ -696,9 +696,9 @@ `(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))) @@ -706,98 +706,98 @@ (defmacro def-complex-format-directive (char lambda-list &body body) #+formatter (let* ((name (or (char-name char) (string char))) - (defun-name (intern (concatenate 'string name "-FORMAT-DIRECTIVE-EXPANDER"))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) + (defun-name (intern (concatenate 'string name "-FORMAT-DIRECTIVE-EXPANDER"))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(%set-format-directive-expander ,char (ext::lambda-block ,defun-name (,directive ,directives) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,directive))) - (butlast lambda-list)) - ,@body)) - `((declare (ignore ,directive ,directives)) - ,@body)))))) + ,@(if lambda-list + `((let ,(mapcar #'(lambda (var) + `(,var + (,(intern (concatenate + 'string + "FORMAT-DIRECTIVE-" + (symbol-name var)) + (symbol-package 'foo)) + ,directive))) + (butlast lambda-list)) + ,@body)) + `((declare (ignore ,directive ,directives)) + ,@body)))))) (defmacro def-format-directive (char lambda-list &body body) #+formatter (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)))) (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 ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,,@body))) - `(progn - (when ,params - (error 'format-error - :complaint "Too many parameters, expected no more than 0" - :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 ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,,@body))) + `(progn + (when ,params + (error 'format-error + :complaint "Too many parameters, expected no more than 0" + :offset (caar ,params))) + ,@body)))) (defmacro def-complex-format-interpreter (char lambda-list &body body) (let ((directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(%set-format-directive-interpreter ,char (lambda (stream ,directive ,directives orig-args args) - (declare (ignorable stream orig-args args)) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,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 + (,(intern (concatenate + 'string + "FORMAT-DIRECTIVE-" + (symbol-name var)) + (symbol-package 'foo)) + ,directive))) + (butlast lambda-list)) + (values (progn ,@body) args))) + `((declare (ignore ,directive ,directives)) + ,@body)))))) (defmacro def-format-interpreter (char lambda-list &body body) (let ((directives (gensym))) @@ -809,23 +809,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 ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,@body)))) + (when ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)) + :offset (caar ,params))) + ,@body)))) ); eval-when @@ -837,33 +837,33 @@ (defun %set-format-directive-interpreter (char fn) (declare (si::c-local)) (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) (declare (si::c-local)) (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))))) ;;;; Simple outputting noise. @@ -877,9 +877,9 @@ (write-char padchar stream)) (and mincol minpad colinc (do ((chars (+ (length string) minpad) (+ chars colinc))) - ((>= chars mincol)) - (dotimes (i colinc) - (write-char padchar stream)))) + ((>= chars mincol)) + (dotimes (i colinc) + (write-char padchar stream)))) (when padleft (write-string string stream))) @@ -887,86 +887,86 @@ #-formatter (declare (si::c-local)) (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-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-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) #-formatter (declare (si::c-local)) (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-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-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-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-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))))) ;;; "printing" as defined in the ANSI CL glossary, which is normative. (defun char-printing-p (char) @@ -984,20 +984,20 @@ (check-output-layout-mode 1) (expand-bind-defaults () params (if (or colonp atsignp) - `(let (,@(when colonp - '((*print-pretty* t))) - ,@(when atsignp - '((*print-level* nil) - (*print-length* nil)))) - (write-object ,(expand-next-arg) stream)) - `(write-object ,(expand-next-arg) stream)))) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (write-object ,(expand-next-arg) stream)) + `(write-object ,(expand-next-arg) stream)))) (def-format-interpreter #\W (colonp atsignp params) (check-output-layout-mode 1) (interpret-bind-defaults () params (let ((*print-pretty* (or colonp *print-pretty*)) - (*print-level* (and atsignp *print-level*)) - (*print-length* (and atsignp *print-length*))) + (*print-level* (and atsignp *print-level*)) + (*print-length* (and atsignp *print-length*))) (write-object (next-arg) stream)))) @@ -1007,61 +1007,61 @@ ;;; 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) #-formatter (declare (si::c-local)) (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) (declare (si::c-local)) (let ((length (length string))) (multiple-value-bind (commas extra) - (truncate (1- length) commainterval) + (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)))) #+formatter (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))) (eval-when (:compile-toplevel :execute) (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))) ) @@ -1115,21 +1115,21 @@ params (if base (format-print-integer stream (next-arg) colonp atsignp base mincol - padchar commachar commainterval) + padchar commachar commainterval) (if atsignp - (if colonp - (format-print-old-roman stream (next-arg)) - (format-print-roman stream (next-arg))) - (if colonp - (format-print-ordinal stream (next-arg)) - (format-print-cardinal stream (next-arg))))))) + (if colonp + (format-print-old-roman stream (next-arg)) + (format-print-roman stream (next-arg))) + (if colonp + (format-print-ordinal stream (next-arg)) + (format-print-cardinal stream (next-arg))))))) (defconstant cardinal-ones #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) (defconstant cardinal-tens #(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety")) + "fifty" "sixty" "seventy" "eighty" "ninety")) (defconstant cardinal-teens #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD @@ -1144,12 +1144,12 @@ (defconstant ordinal-ones #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth") + "fifth" "sixth" "seventh" "eighth" "ninth") "Table of ordinal ones-place digits in English") (defconstant ordinal-tens #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") "Table of ordinal tens-place digits in English") (defun format-print-small-cardinal (stream n) @@ -1160,30 +1160,30 @@ (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) + (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))))))) + (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) #-formatter (declare (si::c-local)) (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) (declare (si::c-local)) @@ -1194,7 +1194,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)))) @@ -1205,29 +1205,29 @@ (write-string "negative " stream)) (let ((number (abs n))) (multiple-value-bind - (top bot) (truncate number 100) + (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))))))) + (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))))))) ;;; Print Roman numerals @@ -1241,9 +1241,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) @@ -1260,15 +1260,15 @@ (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. @@ -1276,40 +1276,40 @@ (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 - (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 + (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)))))) (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)))))) ;;;; Floating point noise. @@ -1321,18 +1321,18 @@ (def-format-directive #\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.")) (expand-bind-defaults ((w nil) (d nil) (k 0) (ovf nil) (pad #\space)) params `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) (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 0) (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) @@ -1340,14 +1340,14 @@ (declare (si::c-local)) (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))) @@ -1358,10 +1358,10 @@ (declare (si::c-local)) (cond ((or (not (or w d)) - #-ecl - (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number)))) + #-ecl + (and (floatp number) + (or (float-infinity-p number) + (float-nan-p number)))) (prin1 number stream) nil) (t @@ -1370,53 +1370,53 @@ (minusp number))) (decf spaceleft)) (multiple-value-bind (str len lpoint tpoint) - (sys::flonum-to-string (abs number) spaceleft d k) - ;; if caller specifically requested no fraction digits, suppress the - ;; trailing zero - (when (eql d 0) + (sys::flonum-to-string (abs number) spaceleft d k) + ;; if caller specifically requested no fraction digits, suppress the + ;; trailing zero + (when (eql d 0) (setq tpoint nil)) - (when w - (decf spaceleft len) + (when w + (decf spaceleft len) ;; obligatory trailing zero (unless explicitly cut with ,d) (when tpoint (decf spaceleft)) - ;; optional leading zero - (when lpoint - (if (or (> spaceleft 0) + ;; optional leading zero + (when lpoint + (if (or (> spaceleft 0) (eql d 0)) - (decf spaceleft) - (setq lpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) + (decf spaceleft) + (setq lpoint 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 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))))))) + t) + (t + (when w (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp 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-directive #\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.")) (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-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 @@ -1444,10 +1444,10 @@ (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 @@ -1465,60 +1465,60 @@ (declare (si::c-local)) (if #-ecl (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (or (float-infinity-p number) + (float-nan-p number))) #+ecl nil (prin1 number stream) (multiple-value-bind (num expt) (sys::scale-exponent (abs number)) (when (< expt 0) ; adjust scale factor (decf k)) - (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) 0)) - (spaceleft (if w - (- w 2 elen - (if (or atsign (minusp 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) - (sys::flonum-to-string num spaceleft fdig k fmin) - (when w - (decf spaceleft flen) - (when lpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq lpoint 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 number) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string fstr 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) 0)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp 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) + (sys::flonum-to-string num spaceleft fdig k fmin) + (when w + (decf spaceleft flen) + (when lpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq lpoint 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 number) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr 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-directive #\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.")) (expand-bind-defaults ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil)) params @@ -1527,8 +1527,8 @@ (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 0) (ovf nil) (pad #\space) (mark nil)) params @@ -1539,14 +1539,14 @@ (declare (si::c-local)) (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))) @@ -1555,40 +1555,40 @@ (declare (si::c-local)) (if #-ecl (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (or (float-infinity-p number) + (float-nan-p number))) #+ecl nil (prin1 number stream) (multiple-value-bind (ignore n) - (sys::scale-exponent (abs number)) - (declare (ignore ignore)) - ;;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. - (unless d - (multiple-value-bind (str len) - (sys::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 0 - 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))))))) + (sys::scale-exponent (abs number)) + (declare (ignore ignore)) + ;;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. + (unless d + (multiple-value-bind (str len) + (sys::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 0 + 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-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))) (def-format-interpreter #\$ (colonp atsignp params) (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params @@ -1600,19 +1600,19 @@ (if (rationalp number) (setq number (coerce number 'single-float))) (if (floatp number) (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) - (sys::flonum-to-string (abs number) nil d) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr stream)) - (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen)) - (write-char pad stream)) - (unless colon (write-string signstr stream)) - (dotimes (i (- n pointplace)) (write-char #\0 stream)) - (write-string str stream))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) + (sys::flonum-to-string (abs number) nil d) + (declare (ignore ig2 ig3)) + (when colon (write-string signstr stream)) + (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen)) + (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))) ;;;; line/page breaks and other stuff like that. @@ -1620,19 +1620,19 @@ (def-format-directive #\% (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.")) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (terpri stream))) + `(dotimes (i ,count) + (terpri stream))) '(terpri stream))) (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)))) @@ -1640,21 +1640,21 @@ (def-format-directive #\& (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.")) (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-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)) @@ -1663,19 +1663,19 @@ (def-format-directive #\| (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.")) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\page stream))) + `(dotimes (i ,count) + (write-char #\page stream))) '(write-char #\page stream))) (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 #\page stream)))) @@ -1683,19 +1683,19 @@ (def-format-directive #\~ (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.")) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\~ stream))) + `(dotimes (i ,count) + (write-char #\~ stream))) '(write-char #\~ stream))) (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)))) @@ -1703,67 +1703,67 @@ (def-complex-format-directive #\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.")) (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 '(#\space #\newline #\tab) - (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 '(#\space #\newline #\tab) + (car directives)) + (cdr directives)) + directives))) (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 '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) + (car directives)) + (cdr directives)) directives)) (def-complex-format-directive #\return (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.")) (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 '(#\space #\newline #\tab) - (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 '(#\space #\newline #\tab) + (car directives)) + (cdr directives)) + directives))) (def-complex-format-interpreter #\return (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 '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) + (car directives)) + (cdr directives)) directives)) ;;;; Tab and simple pretty-printing noise. @@ -1772,31 +1772,31 @@ (check-output-layout-mode 1) (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-interpreter #\T (colonp atsignp params) (check-output-layout-mode 1) (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) (declare (si::c-local)) (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))) @@ -1807,10 +1807,10 @@ (if (#-ecl pp:pretty-stream-p #+ecl sys::pretty-stream-p stream) (pprint-tab :line-relative colrel colinc stream) (let* ((cur (#-ecl sys::charpos #+ecl sys::file-column 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) #-formatter @@ -1818,44 +1818,44 @@ (if (#-ecl pp:pretty-stream-p #+ecl sys::pretty-stream-p stream) (pprint-tab :line colnum colinc stream) (let ((cur (#-ecl sys::charpos #+ecl sys:file-column 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-directive #\_ (colonp atsignp params) (check-output-layout-mode 1) (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-interpreter #\_ (colonp atsignp params) (check-output-layout-mode 1) (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-directive #\I (colonp atsignp params) (check-output-layout-mode 1) (when atsignp (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) + :complaint "Cannot specify the at-sign modifier.")) (expand-bind-defaults ((n 0)) params `(pprint-indent ,(if colonp :current :block) ,n stream))) @@ -1863,7 +1863,7 @@ (check-output-layout-mode 1) (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))) @@ -1873,71 +1873,71 @@ (def-format-directive #\* (colonp atsignp params end) (if atsignp (if colonp - (error 'format-error - :complaint "Cannot specify both colon and at-sign.") - (expand-bind-defaults ((posn 0)) params - (unless *orig-args-available* - (throw 'need-orig-args nil)) - `(if (<= 0 ,posn (length orig-args)) - (setf args (nthcdr ,posn orig-args)) - (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list ,posn (length orig-args)) - :offset ,(1- end))))) + (error 'format-error + :complaint "Cannot specify both colon and at-sign.") + (expand-bind-defaults ((posn 0)) params + (unless *orig-args-available* + (throw 'need-orig-args nil)) + `(if (<= 0 ,posn (length orig-args)) + (setf args (nthcdr ,posn orig-args)) + (error 'format-error + :complaint "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments (list ,posn (length orig-args)) + :offset ,(1- end))))) (if colonp - (expand-bind-defaults ((n 1)) params - (unless *orig-args-available* - (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 ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (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))))) + (expand-bind-defaults ((n 1)) params + (unless *orig-args-available* + (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 ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments + (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))))) (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 ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list posn (length orig-args)))))) + (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 ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments (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 ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)))))))) - (interpret-bind-defaults ((n 1)) params - (dotimes (i n) - (next-arg)))))) + (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 ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments + (list new-posn (length orig-args)))))))) + (interpret-bind-defaults ((n 1)) params + (dotimes (i n) + (next-arg)))))) ;;;; Indirection. @@ -1945,42 +1945,42 @@ (def-format-directive #\? (colonp atsignp params string end) (when colonp (error 'format-error - :complaint "Cannot specify the colon modifier.")) + :complaint "Cannot specify the colon modifier.")) (expand-bind-defaults () params `(handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (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:" + :arguments (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) ,(if atsignp - (if *orig-args-available* - `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args)) - (throw 'need-orig-args nil)) - `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg)))))) + (if *orig-args-available* + `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) + `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg)))))) (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:" - :arguments (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:" + :arguments (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) (if atsignp - (setf args (formatter-aux stream (next-arg) orig-args args)) - (formatter-aux stream (next-arg) (next-arg)))))) + (setf args (formatter-aux stream (next-arg) orig-args args)) + (formatter-aux stream (next-arg) (next-arg)))))) ;;;; Capitalization. @@ -1996,79 +1996,79 @@ (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error - :complaint "No corresponding close paren.")) + :complaint "No corresponding close paren.")) (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 - #-ecl - `(let ((stream (make-case-frob-stream stream - ,(if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - ,@(expand-directive-list before)) - #+ecl - `(let ((string (make-array 10 :element-type 'character - :fill-pointer 0 :adjustable t))) - (unwind-protect - (with-output-to-string (stream string) - ,@(expand-directive-list before)) - (princ (,(if colonp - (if atsignp 'nstring-upcase 'nstring-capitalize) - (if atsignp 'nstring-capitalize-first 'nstring-downcase)) - string) - stream)))) + #-ecl + `(let ((stream (make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before)) + #+ecl + `(let ((string (make-array 10 :element-type 'character + :fill-pointer 0 :adjustable t))) + (unwind-protect + (with-output-to-string (stream string) + ,@(expand-directive-list before)) + (princ (,(if colonp + (if atsignp 'nstring-upcase 'nstring-capitalize) + (if atsignp 'nstring-capitalize-first 'nstring-downcase)) + string) + stream)))) after)))) (def-complex-format-interpreter #\( (colonp atsignp params directives) (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 #-ecl (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) #+ecl (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (jumped t) - (after (nthcdr (1+ posn) directives)) - (string (make-array 10 :element-type 'character - :adjustable t :fill-pointer 0))) - (unwind-protect - (with-output-to-string (stream string) - (setf args (interpret-directive-list stream before orig-args args))) - (princ (funcall - (if colonp - (if atsignp 'nstring-upcase 'nstring-capitalize) - (if atsignp 'nstring-capitalize-first 'nstring-downcase)) - string) stream)) - after)))) + (before (subseq directives 0 posn)) + (jumped t) + (after (nthcdr (1+ posn) directives)) + (string (make-array 10 :element-type 'character + :adjustable t :fill-pointer 0))) + (unwind-protect + (with-output-to-string (stream string) + (setf args (interpret-directive-list stream before orig-args args))) + (princ (funcall + (if colonp + (if atsignp 'nstring-upcase 'nstring-capitalize) + (if atsignp 'nstring-capitalize-first 'nstring-downcase)) + string) stream)) + after)))) (def-complex-format-directive #\) () (error 'format-error - :complaint "No corresponding open paren.")) + :complaint "No corresponding open paren.")) (def-complex-format-interpreter #\) () (error 'format-error - :complaint "No corresponding open paren.")) + :complaint "No corresponding open paren.")) ;;;; Conditionals @@ -2076,20 +2076,20 @@ (defun parse-conditional-directive (directives) (declare (si::c-local)) (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))) (def-complex-format-directive #\[ (colonp atsignp params directives) @@ -2098,108 +2098,108 @@ (parse-conditional-directive directives) (values (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") - (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))))) + (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") + (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))))) remaining))) #+formatter (defun expand-maybe-conditional (sublist) (declare (si::c-local)) (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)))) #+formatter (defun expand-true-false-conditional (true false) (declare (si::c-local)) (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))))) @@ -2208,66 +2208,66 @@ (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-directive #\; () (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>.")) + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>.")) (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.")) (def-complex-format-directive #\] () (error 'format-error - :complaint - "No corresponding open bracket.")) + :complaint + "No corresponding open bracket.")) ;;;; Up-and-out. @@ -2392,69 +2392,69 @@ (nthcdr (1+ posn) directives)))))) (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:" - :arguments (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (formatter-aux 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)))))) + (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:" + :arguments (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (formatter-aux 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)))))) (def-complex-format-directive #\} () (error 'format-error - :complaint "No corresponding open brace.")) + :complaint "No corresponding open brace.")) (def-complex-format-interpreter #\} () (error 'format-error - :complaint "No corresponding open brace.")) + :complaint "No corresponding open brace.")) @@ -2462,28 +2462,28 @@ (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 check-output-layout-mode (mode) (declare (si::c-local)) (when (and *output-layout-mode* - (not (eql *output-layout-mode* mode))) + (not (eql *output-layout-mode* mode))) (error 'format-error - :complaint "Cannot mix ~~W, ~~_, ~~<...~~:>, ~~I, or ~~T with ~~<...~~:;...~~>")) + :complaint "Cannot mix ~~W, ~~_, ~~<...~~:>, ~~I, or ~~T with ~~<...~~:;...~~>")) (setf *output-layout-mode* mode)) (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 @@ -2491,112 +2491,112 @@ (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" - :arguments (list count))) - (expand-format-justification segments colonp atsignp - first-semi params))) + (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" + :arguments (list count))) + (expand-format-justification segments colonp atsignp + first-semi params))) remaining))) (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) + (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" - :arguments (list count))) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params)))) + (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" + :arguments (list count))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) remaining)) (defun parse-format-justification (directives) (declare (si::c-local)) (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)))) #+formatter (defun expand-format-justification (segments colonp atsignp first-semi params) (declare (si::c-local)) (let ((newline-segment-p - (and first-semi - (format-directive-colonp first-semi)))) + (and first-semi + (format-directive-colonp first-semi)))) (when newline-segment-p (check-output-layout-mode 2)) (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 #-ecl (sys::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 #-ecl (sys::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))))) (defun interpret-format-justification (stream orig-args args segments colonp atsignp first-semi params) @@ -2605,55 +2605,55 @@ ((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)) - (check-output-layout-mode 2) - (interpret-bind-defaults - ((extra 0) - (len (or #-ecl (sys::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)) + (check-output-layout-mode 2) + (interpret-bind-defaults + ((extra 0) + (len (or #-ecl (sys::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) #-formatter (declare (si::c-local)) (setf strings (reverse strings)) (when (and (not pad-left) (not pad-right) (null (cdr strings))) (setf pad-left t)) (let* ((num-gaps (1- (length strings))) - (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))) + (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))) (when (and newline-prefix - (> (+ (or (#-ecl sys::charpos #+ecl sys:file-column stream) 0) - length extra-space) - line-len)) + (> (+ (or (#-ecl sys::charpos #+ecl sys:file-column stream) 0) + length extra-space) + line-len)) (write-string newline-prefix stream)) (when pad-left (incf num-gaps)) @@ -2663,21 +2663,21 @@ (incf num-gaps) (setf pad-left t)) (flet ((do-padding (border) - (let ((pad-len (truncate padding num-gaps))) - (decf padding pad-len) - (decf num-gaps) - (unless border - (incf pad-len minpad)) - (dotimes (i pad-len) (write-char padchar stream))))) + (let ((pad-len (truncate padding num-gaps))) + (decf padding pad-len) + (decf num-gaps) + (unless border + (incf pad-len minpad)) + (dotimes (i pad-len) (write-char padchar stream))))) (when pad-left - (do-padding t)) + (do-padding t)) (when strings - (write-string (car strings) stream) - (dolist (string (cdr strings)) - (do-padding nil) - (write-string string stream))) + (write-string (car strings) stream) + (dolist (string (cdr strings)) + (do-padding nil) + (write-string string stream))) (when pad-right - (do-padding t))))) + (do-padding t))))) (defun parse-format-logical-block (segments colonp first-semi close params string end) @@ -2685,126 +2685,126 @@ (check-output-layout-mode 1) (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 - "Cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" - :arguments (list prefix-p) - :offset (1- (format-directive-end directive))) - (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 ~~<...~~:>."))))) + (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 ~~<...~~:>" + :arguments (list prefix-p) + :offset (1- (format-directive-end directive))) + (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) (declare (si::c-local)) (if list (let ((directive (car list))) - (if (simple-string-p directive) - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines (cdr list) - string - (+ offset (length directive)))) - (cons directive - (add-fill-style-newlines (cdr list) - string - (format-directive-end directive))))) + (if (simple-string-p directive) + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines (cdr list) + string + (+ offset (length directive)))) + (cons directive + (add-fill-style-newlines (cdr list) + string + (format-directive-end directive))))) nil)) (defun add-fill-style-newlines-aux (literal string offset) (declare (si::c-local)) (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)))) #+formatter (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* 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* t)) + (expand-directive-list insides))))))) (defun interpret-format-logical-block (stream orig-args args prefix per-line-p insides suffix atsignp) (declare (si::c-local)) (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)) (def-complex-format-directive #\> () (error 'format-error - :complaint "No corresponding open bracket.")) + :complaint "No corresponding open bracket.")) ;;;; User-defined method. @@ -2813,51 +2813,51 @@ (let ((symbol (extract-user-function-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)))))) (def-format-interpreter #\/ (string start end colonp atsignp params) (let ((symbol (extract-user-function-name string start end))) (collect ((args)) (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (case param - (:arg (let ((x (next-arg))) (when x (args x)))) - (:remaining (args (length args))) - (t (args param))))) + (let ((param (cdr param-and-offset))) + (case param + (:arg (let ((x (next-arg))) (when x (args x)))) + (:remaining (args (length args))) + (t (args param))))) (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) (defun extract-user-function-name (string start end) (declare (si::c-local)) (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 - ;; quit 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 + ;; quit 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 - (error 'format-error - :complaint "No package named ~S" - :arguments (list package-name))) + (error 'format-error + :complaint "No package named ~S" + :arguments (list package-name))) (intern (cond ((and second-colon (= second-colon (1+ first-colon))) (subseq name (1+ second-colon))) @@ -2883,9 +2883,9 @@ (declare (si::c-local)) (handler-case (catch 'give-up - ;; For the side effect of validating the control string. - (%formatter string) - (%min/max-format-args (tokenize-control-string string))) + ;; For the side effect of validating the control string. + (%formatter string) + (%min/max-format-args (tokenize-control-string string))) (format-error (e) (format nil "~a" e)))) @@ -2894,39 +2894,39 @@ (declare (si::c-local)) (let ((min-req 0) (max-req 0)) (flet ((incf-both (&optional (n 1)) - (incf min-req n) - (incf max-req n))) + (incf min-req n) + (incf max-req n))) (loop - (let ((dir (pop directives))) - (when (null dir) - (return (values min-req max-req))) - (when (format-directive-p dir) - (incf-both (count :arg (format-directive-params dir) :key #'cdr)) - (let ((c (format-directive-character dir))) - (cond ((find c "ABCDEFGORSWX$/") - (incf-both)) - ((char= c #\P) - (unless (format-directive-colonp dir) - (incf-both))) - ((or (find c "IT%&|_<>();") (char= c #\newline))) - ((char= c #\[) - (multiple-value-bind (min max remaining) - (%min/max-conditional-args dir directives) - (setq directives remaining) - (incf min-req min) - (incf max-req max))) - ((char= c #\{) - (multiple-value-bind (min max remaining) - (%min/max-iteration-args dir directives) - (setq directives remaining) - (incf min-req min) - (incf max-req max))) - ((char= c #\?) - (cond ((format-directive-atsignp dir) - (incf min-req) - (setq max-req most-positive-fixnum)) - (t (incf-both 2)))) - (t (throw 'give-up nil)))))))))) + (let ((dir (pop directives))) + (when (null dir) + (return (values min-req max-req))) + (when (format-directive-p dir) + (incf-both (count :arg (format-directive-params dir) :key #'cdr)) + (let ((c (format-directive-character dir))) + (cond ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (format-directive-colonp dir) + (incf-both))) + ((or (find c "IT%&|_<>();") (char= c #\newline))) + ((char= c #\[) + (multiple-value-bind (min max remaining) + (%min/max-conditional-args dir directives) + (setq directives remaining) + (incf min-req min) + (incf max-req max))) + ((char= c #\{) + (multiple-value-bind (min max remaining) + (%min/max-iteration-args dir directives) + (setq directives remaining) + (incf min-req min) + (incf max-req max))) + ((char= c #\?) + (cond ((format-directive-atsignp dir) + (incf min-req) + (setq max-req most-positive-fixnum)) + (t (incf-both 2)))) + (t (throw 'give-up nil)))))))))) ;;; ;;; ANSI: if arg is out of range, no clause is selected. That means @@ -2940,28 +2940,28 @@ (parse-conditional-directive directives) (declare (ignore last-semi-with-colon-p)) (let ((sub-max (loop for s in sublists maximize - (nth-value 1 (%min/max-format-args s)))) - (min-req 1) - max-req) + (nth-value 1 (%min/max-format-args s)))) + (min-req 1) + max-req) (cond ((format-directive-atsignp conditional) - (setq max-req (max 1 sub-max))) - ((loop for p in (format-directive-params conditional) - thereis (or (integerp (cdr p)) - (memq (cdr p) '(:remaining :arg)))) - (setq min-req 0) - (setq max-req sub-max)) - (t - (setq max-req (1+ sub-max)))) + (setq max-req (max 1 sub-max))) + ((loop for p in (format-directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (setq min-req 0) + (setq max-req sub-max)) + (t + (setq max-req (1+ sub-max)))) (values min-req max-req remaining)))) (defun %min/max-iteration-args (iteration directives) #-formatter (declare (si::c-local)) (let* ((close (find-directive directives #\} nil)) - (posn (position close directives)) - (remaining (nthcdr (1+ posn) directives))) + (posn (position close directives)) + (remaining (nthcdr (1+ posn) directives))) (if (format-directive-atsignp iteration) - (values (if (zerop posn) 1 0) most-positive-fixnum remaining) - (let ((nreq (if (zerop posn) 2 1))) - (values nreq nreq remaining))))) + (values (if (zerop posn) 1 0) most-positive-fixnum remaining) + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining))))) ) diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp index 6f8a3a2b6..ee13d966f 100644 --- a/src/lsp/helpfile.lsp +++ b/src/lsp/helpfile.lsp @@ -32,7 +32,7 @@ "Args: (&optional hash-size) Sets up a new hash table for storing documentation strings." (push (make-hash-table :test #'eql :size size) - *documentation-pool*)) + *documentation-pool*)) (defun record-cons (record key sub-key) (let ((cons (cons key sub-key))) @@ -71,7 +71,7 @@ Sets up a new hash table for storing documentation strings." (when (hash-table-p dict) (let ((record (rem-record-field (gethash object dict) key sub-key))) - (if record + (if record (si::hash-set object dict record) (remhash object dict)))))) @@ -132,19 +132,19 @@ the help file." "Args: (symbol doc-type) Returns the DOC-TYPE doc-string of SYMBOL; NIL if none exists. Possible doc- types are: - FUNCTION (special forms, macros, and functions) - VARIABLE (global variables) - TYPE (type specifiers) - STRUCTURE (structures) - SETF (SETF methods) + FUNCTION (special forms, macros, and functions) + VARIABLE (global variables) + TYPE (type specifiers) + STRUCTURE (structures) + SETF (SETF methods) All built-in special forms, macros, functions, and variables have their doc- strings." (cond ((member type '(function type variable setf structure)) - (when (not (symbolp object)) - (error "~S is not a symbol." object)) - (si::get-documentation object type)) - (t - (error "~S is an unknown documentation type" type)))) + (when (not (symbolp object)) + (error "~S is not a symbol." object)) + (si::get-documentation object type)) + (t + (error "~S is an unknown documentation type" type)))) (defun make-dspec (definition) (when (consp definition) diff --git a/src/lsp/init.lsp b/src/lsp/init.lsp index 4d636d672..ccefc4ae1 100644 --- a/src/lsp/init.lsp +++ b/src/lsp/init.lsp @@ -13,10 +13,10 @@ (defun compile-if-needed (file) (let ((cfile-date (file-write-date (merge-pathnames file #".c")))) (when (or (not cfile-date) - (> (file-write-date (merge-pathnames file #".lsp")) - cfile-date)) + (> (file-write-date (merge-pathnames file #".lsp")) + cfile-date)) (compile-file file :c-file t :h-file t :data-file t - :output-file nil :system-p t))) + :output-file nil :system-p t))) ) #| (compile-if-needed "defmacro") diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index 0e9a7bc6f..fd5dcdb53 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -39,8 +39,8 @@ Possible keywords are :INDEX, :START, and :END." ,@ds (UNWIND-PROTECT (MULTIPLE-VALUE-PROG1 - (PROGN ,@b) - (SETF ,index (FILE-POSITION ,var))) + (PROGN ,@b) + (SETF ,index (FILE-POSITION ,var))) (CLOSE ,var)))) `(LET ((,var (MAKE-STRING-INPUT-STREAM ,string ,start ,end))) ,@body))) @@ -52,9 +52,9 @@ the value of STRING-FORM. If STRING-FORM is not given, a new string is used. The stream is automatically closed on exit and the string is returned." (if string `(LET* ((,var (MAKE-STRING-OUTPUT-STREAM-FROM-STRING ,string)) - (,(gensym) ,element-type)) - ;; We must evaluate element-type if it has been supplied by the user. - ;; Even if we ignore the value afterwards. + (,(gensym) ,element-type)) + ;; We must evaluate element-type if it has been supplied by the user. + ;; Even if we ignore the value afterwards. ,@body) `(LET ((,var (MAKE-STRING-OUTPUT-STREAM ,@r))) ,@body @@ -159,16 +159,16 @@ printed. If FORMAT-STRING is NIL, however, no prompt will appear." ((null arg) ;; readably-pretty-printed array: #A(type dims initial-contents) (let ((elt-type (car initial-contents)) - (dims (cadr initial-contents)) - (initial-contents (caddr initial-contents))) - (make-array dims :element-type elt-type :initial-contents initial-contents))) + (dims (cadr initial-contents)) + (initial-contents (caddr initial-contents))) + (make-array dims :element-type elt-type :initial-contents initial-contents))) (t (do* ((i 0 (1+ i)) - (d nil (cons (length ic) d)) - (ic initial-contents (if (zerop (length ic)) ic (elt ic 0)))) + (d nil (cons (length ic) d)) + (ic initial-contents (if (zerop (length ic)) ic (elt ic 0)))) ((>= i arg) (make-array (nreverse d) :initial-contents initial-contents)) - (declare (fixnum i))))))) + (declare (fixnum i))))))) (set-dispatch-macro-character #\# #\a 'sharp-a-reader) (set-dispatch-macro-character #\# #\A 'sharp-a-reader) @@ -205,37 +205,37 @@ If FILESPEC is given, starts recording the interaction to the specified file. FILESPEC may be a symbol, a string, a pathname, or a file stream. If FILESPEC is not given, ends the recording." (cond (*dribble-closure* - (funcall *dribble-closure* psp)) - ((null psp) - (error "Not in dribble.")) - (t - (let* ((namestring (namestring pathname)) + (funcall *dribble-closure* psp)) + ((null psp) + (error "Not in dribble.")) + (t + (let* ((namestring (namestring pathname)) (stream (open pathname :direction :output - :if-exists :supersede - :if-does-not-exist :create)) - (dribble-stream (make-two-way-stream - (make-echo-stream *terminal-io* stream) - (make-broadcast-stream *terminal-io* stream))) - (standard-input *standard-input*) - (standard-output *standard-output*) - (closure #'(lambda (pathname-p) - (when pathname-p - (error "Already in dribble (to ~A)" namestring)) - (unless (and (eq dribble-stream *standard-input*) - (eq dribble-stream *standard-output*)) - (warn "Stream variables rebound while DRIBBLE is on.~%Some output may be lost.")) - (format stream "~&Finished dribbling to ~A." namestring) - (close stream) - (setq *standard-input* standard-input - *standard-output* standard-output - *dribble-closure* nil)))) + :if-exists :supersede + :if-does-not-exist :create)) + (dribble-stream (make-two-way-stream + (make-echo-stream *terminal-io* stream) + (make-broadcast-stream *terminal-io* stream))) + (standard-input *standard-input*) + (standard-output *standard-output*) + (closure #'(lambda (pathname-p) + (when pathname-p + (error "Already in dribble (to ~A)" namestring)) + (unless (and (eq dribble-stream *standard-input*) + (eq dribble-stream *standard-output*)) + (warn "Stream variables rebound while DRIBBLE is on.~%Some output may be lost.")) + (format stream "~&Finished dribbling to ~A." namestring) + (close stream) + (setq *standard-input* standard-input + *standard-output* standard-output + *dribble-closure* nil)))) (multiple-value-bind (sec min hour day month year) (get-decoded-time) (format dribble-stream "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)." namestring year month day hour min sec) - (setq *standard-input* dribble-stream - *standard-output* dribble-stream - *dribble-closure* closure))))) + (setq *standard-input* dribble-stream + *standard-output* dribble-stream + *dribble-closure* closure))))) (values)) ;(provide 'iolib) @@ -248,8 +248,8 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, (with-clean-symbols (%progv-list) `(let ((%progv-list +io-syntax-progv-list+)) (progv (si:cons-car %progv-list) - (si:cons-cdr %progv-list) - ,@body)))) + (si:cons-cdr %progv-list) + ,@body)))) (defmacro with-ecl-io-syntax (&body body) "Syntax: ({forms}*) @@ -258,8 +258,8 @@ the one used internally by ECL compiled files." (with-clean-symbols (%progv-list) `(let ((%progv-list +ecl-syntax-progv-list+)) (progv (si:cons-car %progv-list) - (si:cons-cdr %progv-list) - ,@body)))) + (si:cons-cdr %progv-list) + ,@body)))) #-formatter (defmacro formatter (control-string) @@ -267,11 +267,11 @@ the one used internally by ECL compiled files." (si::formatter-aux *standard-output* ,control-string args))) (defmacro print-unreadable-object - ((object stream &key type identity) &body body) + ((object stream &key type identity) &body body) (if body `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) + (print-unreadable-object-function + ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) (let* ((basic-encodings @@ -296,17 +296,17 @@ the one used internally by ECL compiled files." #+unicode (let ((filename (make-pathname :name (symbol-name name) :defaults "sys:encodings;"))) (cond ((probe-file filename) - (load filename :verbose nil) - name) - ((probe-file (setf filename (make-pathname :type "BIN" :defaults filename))) - (with-open-file (in filename :element-type '(unsigned-byte 16) - :external-format :big-endian) - (let* ((l (read-byte in)) - (s (make-array l :element-type '(unsigned-byte 16) :initial-element 0))) - (read-sequence s in) - s))) - (t - (error "Unable to find mapping file ~A for encoding ~A" filename name))))) + (load filename :verbose nil) + name) + ((probe-file (setf filename (make-pathname :type "BIN" :defaults filename))) + (with-open-file (in filename :element-type '(unsigned-byte 16) + :external-format :big-endian) + (let* ((l (read-byte in)) + (s (make-array l :element-type '(unsigned-byte 16) :initial-element 0))) + (read-sequence s in) + s))) + (t + (error "Unable to find mapping file ~A for encoding ~A" filename name))))) (defun ext:make-encoding (mapping) #-unicode @@ -316,29 +316,29 @@ the one used internally by ECL compiled files." ((symbolp mapping) (let ((var (intern (symbol-name mapping) (find-package "EXT")))) (unless (boundp var) - (setf (symbol-value var) (ext::make-encoding (load-encoding mapping)))) + (setf (symbol-value var) (ext::make-encoding (load-encoding mapping)))) (symbol-value var))) ((consp mapping) (let ((output (make-hash-table :size 512 :test 'eq))) (dolist (record mapping output) - (let* ((byte (car record)) - (unicode (cdr record)) - (unicode-char (code-char unicode))) - (when (> byte #xFF) - (setf (gethash (ash byte -8) output) t)) - (setf (gethash byte output) unicode-char) - (setf (gethash unicode-char output) byte))))) + (let* ((byte (car record)) + (unicode (cdr record)) + (unicode-char (code-char unicode))) + (when (> byte #xFF) + (setf (gethash (ash byte -8) output) t)) + (setf (gethash byte output) unicode-char) + (setf (gethash unicode-char output) byte))))) ((arrayp mapping) (do* ((l (array-total-size mapping)) - (output (make-hash-table :size (floor (* 1.5 l)) :test 'eq)) - (i 0 (+ 2 i))) - ((>= i l) output) - (let* ((byte (aref mapping i)) - (unicode (aref mapping (1+ i))) - (unicode-char (code-char unicode))) - (when (> byte #xFF) - (setf (gethash (ash byte -8) output) t)) - (setf (gethash byte output) unicode-char) - (setf (gethash unicode-char output) byte)))) + (output (make-hash-table :size (floor (* 1.5 l)) :test 'eq)) + (i 0 (+ 2 i))) + ((>= i l) output) + (let* ((byte (aref mapping i)) + (unicode (aref mapping (1+ i))) + (unicode-char (code-char unicode))) + (when (> byte #xFF) + (setf (gethash (ash byte -8) output) t)) + (setf (gethash byte output) unicode-char) + (setf (gethash unicode-char output) byte)))) (t (error "Not a valid external format ~A" mapping)))) diff --git a/src/lsp/listlib.lsp b/src/lsp/listlib.lsp index 4220eadc5..430bf5290 100644 --- a/src/lsp/listlib.lsp +++ b/src/lsp/listlib.lsp @@ -23,10 +23,10 @@ Returns, as a list, the union of elements in LIST1 and in LIST2." (or first list2)) (unless (member1 (car x) list2 test test-not key) (if last - (progn (rplacd last (cons (car x) nil)) - (setq last (cdr last))) - (progn (setq first (cons (car x) nil)) - (setq last first)))))) + (progn (rplacd last (cons (car x) nil)) + (setq last (cdr last))) + (progn (setq first (cons (car x) nil)) + (setq last first)))))) (defun nunion (list1 list2 &key test test-not key) "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not) @@ -38,8 +38,8 @@ Destructive UNION. Both LIST1 and LIST2 may be destroyed." (or first list2)) (unless (member1 (car x) list2 test test-not key) (if last - (rplacd last x) - (setq first x)) + (rplacd last x) + (setq first x)) (setq last x)))) (defun intersection (list1 list2 &key test test-not key) @@ -63,8 +63,8 @@ Destructive INTERSECTION. Only LIST1 may be destroyed." first) (when (member1 (car x) list2 test test-not key) (if last - (rplacd last x) - (setq first x)) + (rplacd last x) + (setq first x)) (setq last x)))) (defun set-difference (list1 list2 &key test test-not key) @@ -86,8 +86,8 @@ Destructive SET-DIFFERENCE. Only LIST1 may be destroyed." first) (unless (member1 (car x) list2 test test-not key) (if last - (rplacd last x) - (setq first x)) + (rplacd last x) + (setq first x)) (setq last x)))) (defun swap-args (f) @@ -105,7 +105,7 @@ those elements of LIST2 that are not elements of LIST1." "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not) Destructive SET-EXCLUSIVE-OR. Both LIST1 and LIST2 may be destroyed." (nconc (set-difference list1 list2 :test test :test-not test-not :key key) - (nset-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key))) + (nset-difference list2 list1 :test (swap-args test) :test-not (swap-args test-not) :key key))) (defun subsetp (list1 list2 &key test test-not key) "Args: (list1 list2 &key (key #'identity) (test #'eql) test-not) diff --git a/src/lsp/loop.lsp b/src/lsp/loop.lsp index cbc508b2e..8e0582643 100644 --- a/src/lsp/loop.lsp +++ b/src/lsp/loop.lsp @@ -38,9 +38,9 @@ ;;; ;;; LOOP documentation is still probably available from the MIT Laboratory ;;; for Computer Science publications office: -;;; LCS Publications -;;; 545 Technology Square -;;; Cambridge, MA 02139 +;;; LCS Publications +;;; 545 Technology Square +;;; Cambridge, MA 02139 ;;; It is Technical Memo 169, "LOOP Iteration Macro", and is very old. The ;;; most up-to-date documentation on this version of LOOP is that in the NIL ;;; Reference Manual (TR-311 from LCS Publications); while you wouldn't @@ -55,9 +55,9 @@ ;;; [gsb@palladian] 30-apr-86 00:26 File Created from NIL's LOOP version 829 ;;; [gsb@palladian] 30-oct-86 18:23 don't generate (type notype var) decls, special-case notype into T. -;;; (The NOTYPE type keyword needs to be around for compatibility.) +;;; (The NOTYPE type keyword needs to be around for compatibility.) ;;; [gsb@palladian] 30-oct-86 18:48 bogus case clause in loop-do-collect. Syntax:common-lisp in file -;;; attribute list, for symbolics gratuitousness. +;;; attribute list, for symbolics gratuitousness. ;;; [jeff@palladian] 22-jul-87 19:44 Export loop-simple-error. ;;;------------------------------------------------------------------------ ;;;------- End of official change history -- note local fixes below ------- @@ -85,8 +85,8 @@ ;(in-package 'loop-si-kludge) ;(export '(loop-tequal loop-tassoc loop-tmember *loop-use-system-destructuring?* -; loop-named-variable loop-simplep loop-simplep-1 -; loop-sequencer loop-sequence-elements-path)) +; loop-named-variable loop-simplep loop-simplep-1 +; loop-sequencer loop-sequence-elements-path)) (in-package "SYSTEM") @@ -95,11 +95,11 @@ ;shadow? (export '(loop loop-finish define-loop-macro define-loop-path - define-loop-sequence-path)) + define-loop-sequence-path)) (export '(loop-tequal loop-tassoc loop-tmember *loop-use-system-destructuring?* - loop-named-variable loop-simple-error loop-simplep loop-simplep-1 - loop-sequencer loop-sequence-elements-path)) + loop-named-variable loop-simple-error loop-simplep loop-simplep-1 + loop-sequencer loop-sequence-elements-path)) ;require? @@ -125,7 +125,7 @@ (defmacro loop-warn (unquoted-message &optional (datum nil datump)) (if datump `(warn ,(concatenate 'string "LOOP: " unquoted-message " -- ~{~S~^ ~}") - ,datum) + ,datum) `(warn ',(concatenate 'string "LOOP: " unquoted-message)))) @@ -144,11 +144,11 @@ (defun loop-make-psetq (frobs) (and frobs - (loop-make-setq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) + (loop-make-setq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) (defvar *loop-use-system-destructuring?* @@ -160,71 +160,71 @@ ;(defmacro loop-desetq (&rest x) ; (let ((*loop-desetq-temporary* nil)) ; (let ((setq-form (loop-make-desetq x))) -; (if *loop-desetq-temporary* -; `((lambda (,*loop-desetq-temporary*) ,setq-form) nil) -; setq-form)))) +; (if *loop-desetq-temporary* +; `((lambda (,*loop-desetq-temporary*) ,setq-form) nil) +; setq-form)))) (defun loop-make-desetq (x) (if *loop-use-system-destructuring?* (cons (do ((l x (cddr l))) ((null l) 'setq) - (or (and (not (null (car l))) (symbolp (car l))) - (return 'desetq))) - x) + (or (and (not (null (car l))) (symbolp (car l))) + (return 'desetq))) + x) (do ((x x (cddr x)) (r nil) (var) (val)) - ((null x) (and r (cons 'setq r))) - (setq var (car x) val (cadr x)) - (cond ((and (not (atom var)) - (not (atom val)) - (not (and (member (car val) '(car cdr cadr cddr caar cdar)) - (atom (cadr val))))) - (setq x (list* (or *loop-desetq-temporary* - (setq *loop-desetq-temporary* - (loop-gentemp 'loop-desetq-))) - val var *loop-desetq-temporary* (cddr x))))) - (setq r (nconc r (loop-desetq-internal (car x) (cadr x))))))) + ((null x) (and r (cons 'setq r))) + (setq var (car x) val (cadr x)) + (cond ((and (not (atom var)) + (not (atom val)) + (not (and (member (car val) '(car cdr cadr cddr caar cdar)) + (atom (cadr val))))) + (setq x (list* (or *loop-desetq-temporary* + (setq *loop-desetq-temporary* + (loop-gentemp 'loop-desetq-))) + val var *loop-desetq-temporary* (cddr x))))) + (setq r (nconc r (loop-desetq-internal (car x) (cadr x))))))) (defun loop-desetq-internal (var val) (cond ((null var) nil) - ((atom var) (list var val)) - (t (nconc (loop-desetq-internal (car var) `(car ,val)) - (loop-desetq-internal (cdr var) `(cdr ,val)))))) + ((atom var) (list var val)) + (t (nconc (loop-desetq-internal (car var) `(car ,val)) + (loop-desetq-internal (cdr var) `(cdr ,val)))))) (defun loop-make-setq (pairs) (and pairs (loop-make-desetq pairs))) -(defconstant +loop-keyword-alist+ ;clause introducers - '( (named loop-do-named) - (initially loop-do-initially) - (finally loop-do-finally) - (nodeclare loop-nodeclare) - (do loop-do-do) - (doing loop-do-do) - (return loop-do-return) - (collect loop-do-collect list) - (collecting loop-do-collect list) - (append loop-do-collect append) - (appending loop-do-collect append) - (nconc loop-do-collect nconc) - (nconcing loop-do-collect nconc) - (count loop-do-collect count) - (counting loop-do-collect count) - (sum loop-do-collect sum) - (summing loop-do-collect sum) - (maximize loop-do-collect max) - (minimize loop-do-collect min) - (always loop-do-always nil) ;Normal, do always - (never loop-do-always t) ; Negate the test on always. - (thereis loop-do-thereis) - (while loop-do-while nil while) ; Normal, do while - (until loop-do-while t until) ; Negate the test on while - (when loop-do-when nil when) ; Normal, do when - (if loop-do-when nil if) ; synonymous - (unless loop-do-when t unless) ; Negate the test on when - (with loop-do-with))) +(defconstant +loop-keyword-alist+ ;clause introducers + '( (named loop-do-named) + (initially loop-do-initially) + (finally loop-do-finally) + (nodeclare loop-nodeclare) + (do loop-do-do) + (doing loop-do-do) + (return loop-do-return) + (collect loop-do-collect list) + (collecting loop-do-collect list) + (append loop-do-collect append) + (appending loop-do-collect append) + (nconc loop-do-collect nconc) + (nconcing loop-do-collect nconc) + (count loop-do-collect count) + (counting loop-do-collect count) + (sum loop-do-collect sum) + (summing loop-do-collect sum) + (maximize loop-do-collect max) + (minimize loop-do-collect min) + (always loop-do-always nil) ;Normal, do always + (never loop-do-always t) ; Negate the test on always. + (thereis loop-do-thereis) + (while loop-do-while nil while) ; Normal, do while + (until loop-do-while t until) ; Negate the test on while + (when loop-do-when nil when) ; Normal, do when + (if loop-do-when nil if) ; synonymous + (unless loop-do-when t unless) ; Negate the test on when + (with loop-do-with))) (defconstant +loop-iteration-keyword-alist+ @@ -233,41 +233,41 @@ (repeat loop-do-repeat))) -(defconstant +loop-for-keyword-alist+ ;Types of FOR +(defconstant +loop-for-keyword-alist+ ;Types of FOR '( (= loop-for-equals) (first loop-for-first) - (in loop-list-stepper car) - (on loop-list-stepper nil) - (from loop-for-arithmetic from) - (downfrom loop-for-arithmetic downfrom) - (upfrom loop-for-arithmetic upfrom) - (below loop-for-arithmetic below) - (to loop-for-arithmetic to) - (being loop-for-being))) + (in loop-list-stepper car) + (on loop-list-stepper nil) + (from loop-for-arithmetic from) + (downfrom loop-for-arithmetic downfrom) + (upfrom loop-for-arithmetic upfrom) + (below loop-for-arithmetic below) + (to loop-for-arithmetic to) + (being loop-for-being))) (defvar *loop-prog-names*) -(defvar *loop-macro-environment*) ;Second arg to macro functions, - ;passed to macroexpand. +(defvar *loop-macro-environment*) ;Second arg to macro functions, + ;passed to macroexpand. -(defvar *loop-path-keyword-alist* nil) ; PATH functions -(defvar *loop-named-variables*) ; see LOOP-NAMED-VARIABLE -(defvar *loop-variables*) ; Variables local to the loop -(defvar *loop-declarations*) ; Local dcls for above -(defvar *loop-nodeclare*) ; but don't declare these +(defvar *loop-path-keyword-alist* nil) ; PATH functions +(defvar *loop-named-variables*) ; see LOOP-NAMED-VARIABLE +(defvar *loop-variables*) ; Variables local to the loop +(defvar *loop-declarations*) ; Local dcls for above +(defvar *loop-nodeclare*) ; but don't declare these (defvar *loop-variable-stack*) (defvar *loop-declaration-stack*) -(defvar *loop-desetq-crocks*) ; see loop-make-variable -(defvar *loop-desetq-stack*) ; and loop-translate-1 -(defvar *loop-prologue*) ;List of forms in reverse order -(defvar *loop-wrappers*) ;List of wrapping forms, innermost first +(defvar *loop-desetq-crocks*) ; see loop-make-variable +(defvar *loop-desetq-stack*) ; and loop-translate-1 +(defvar *loop-prologue*) ;List of forms in reverse order +(defvar *loop-wrappers*) ;List of wrapping forms, innermost first (defvar *loop-before-loop*) -(defvar *loop-body*) ;.. -(defvar *loop-after-body*) ;.. for FOR steppers -(defvar *loop-epilogue*) ;.. -(defvar *loop-after-epilogue*) ;So COLLECT's RETURN comes after FINALLY -(defvar *loop-conditionals*) ;If non-NIL, condition for next form in body +(defvar *loop-body*) ;.. +(defvar *loop-after-body*) ;.. for FOR steppers +(defvar *loop-epilogue*) ;.. +(defvar *loop-after-epilogue*) ;So COLLECT's RETURN comes after FINALLY +(defvar *loop-conditionals*) ;If non-NIL, condition for next form in body ;The above is actually a list of entries of the form ;(cond (condition forms...)) ;When it is output, each successive condition will get @@ -276,15 +276,15 @@ ;COND from a user-generated COND. ;When ELSE is used, each cond can get a second clause -(defvar *loop-when-it-variable*) ;See LOOP-DO-WHEN -(defvar *loop-never-stepped-variable*) ; see LOOP-FOR-FIRST -(defvar *loop-emitted-body?*) ; see LOOP-EMIT-BODY, - ; and LOOP-DO-FOR -(defvar *loop-iteration-variables*) ; LOOP-MAKE-ITERATION-VARIABLE -(defvar *loop-iteration-variablep*) ; ditto -(defvar *loop-collect-cruft*) ; for multiple COLLECTs (etc) +(defvar *loop-when-it-variable*) ;See LOOP-DO-WHEN +(defvar *loop-never-stepped-variable*) ; see LOOP-FOR-FIRST +(defvar *loop-emitted-body?*) ; see LOOP-EMIT-BODY, + ; and LOOP-DO-FOR +(defvar *loop-iteration-variables*) ; LOOP-MAKE-ITERATION-VARIABLE +(defvar *loop-iteration-variablep*) ; ditto +(defvar *loop-collect-cruft*) ; for multiple COLLECTs (etc) (defvar *loop-source-code*) -(defvar *loop-duplicate-code* nil) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC +(defvar *loop-duplicate-code* nil) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC ;;;; Construct a value return @@ -345,64 +345,64 @@ collected result will be returned as the value of the LOOP." (defun loop-end-testify (list-of-forms) (if (null list-of-forms) nil - `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))) + `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))) (defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b - lastdiff) + lastdiff) (do ((l1 (nreverse *loop-before-loop*) (cdr l1)) - (l2 (nreverse *loop-after-body*) (cdr l2))) - ((equal l1 l2) - (setq *loop-body* (nconc (delete nil l1) (nreverse *loop-body*)))) + (l2 (nreverse *loop-after-body*) (cdr l2))) + ((equal l1 l2) + (setq *loop-body* (nconc (delete nil l1) (nreverse *loop-body*)))) (push (car l1) before) (push (car l2) after)) (cond ((not (null *loop-duplicate-code*)) - (setq *loop-before-loop* (nreverse (delete nil before)) - *loop-after-body* (nreverse (delete nil after)))) - (t (setq *loop-before-loop* nil *loop-after-body* nil - before (nreverse before) after (nreverse after)) - (do ((bb before (cdr bb)) (aa after (cdr aa))) - ((null aa)) - (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa)) - ((not (loop-simplep (car aa))) ;Mustn't duplicate - (return nil)))) - (cond (lastdiff ;Down through lastdiff should be duplicated - (do nil (nil) - (and (car before) (push (car before) *loop-before-loop*)) - (and (car after) (push (car after) *loop-after-body*)) - (setq before (cdr before) after (cdr after)) - (and (eq after (cdr lastdiff)) (return nil))) - (setq *loop-before-loop* (nreverse *loop-before-loop*) - *loop-after-body* (nreverse *loop-after-body*)))) - (do ((bb (nreverse before) (cdr bb)) - (aa (nreverse after) (cdr aa))) - ((null aa)) - (setq a (car aa) b (car bb)) - (cond ((and (null a) (null b))) - ((equal a b) - (loop-output-group groupb groupa) - (push a *loop-body*) - (setq groupb nil groupa nil)) - (t (and a (push a groupa)) (and b (push b groupb))))) - (loop-output-group groupb groupa))) + (setq *loop-before-loop* (nreverse (delete nil before)) + *loop-after-body* (nreverse (delete nil after)))) + (t (setq *loop-before-loop* nil *loop-after-body* nil + before (nreverse before) after (nreverse after)) + (do ((bb before (cdr bb)) (aa after (cdr aa))) + ((null aa)) + (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa)) + ((not (loop-simplep (car aa))) ;Mustn't duplicate + (return nil)))) + (cond (lastdiff ;Down through lastdiff should be duplicated + (do nil (nil) + (and (car before) (push (car before) *loop-before-loop*)) + (and (car after) (push (car after) *loop-after-body*)) + (setq before (cdr before) after (cdr after)) + (and (eq after (cdr lastdiff)) (return nil))) + (setq *loop-before-loop* (nreverse *loop-before-loop*) + *loop-after-body* (nreverse *loop-after-body*)))) + (do ((bb (nreverse before) (cdr bb)) + (aa (nreverse after) (cdr aa))) + ((null aa)) + (setq a (car aa) b (car bb)) + (cond ((and (null a) (null b))) + ((equal a b) + (loop-output-group groupb groupa) + (push a *loop-body*) + (setq groupb nil groupa nil)) + (t (and a (push a groupa)) (and b (push b groupb))))) + (loop-output-group groupb groupa))) (and *loop-never-stepped-variable* - (push `(setq ,*loop-never-stepped-variable* nil) *loop-after-body*)) + (push `(setq ,*loop-never-stepped-variable* nil) *loop-after-body*)) nil) (defun loop-output-group (before after) (and (or after before) - (let ((v (or *loop-never-stepped-variable* - (setq *loop-never-stepped-variable* - (loop-make-variable - (loop-gentemp 'loop-iter-flag-) t nil))))) - (push (cond ((not before) - `(unless ,v (progn ,@after))) - ((not after) - `(when ,v (progn ,@before))) - (t `(cond (,v ,@before) (t ,@after)))) - *loop-body*)))) + (let ((v (or *loop-never-stepped-variable* + (setq *loop-never-stepped-variable* + (loop-make-variable + (loop-gentemp 'loop-iter-flag-) t nil))))) + (push (cond ((not before) + `(unless ,v (progn ,@after))) + ((not after) + `(when ,v (progn ,@before))) + (t `(cond (,v ,@before) (t ,@after)))) + *loop-body*)))) (defun loop-translate-1 (*loop-source-code*) @@ -437,100 +437,100 @@ collected result will be returned as the value of the LOOP." (progvars)) ((null *loop-source-code*) (and *loop-conditionals* - (loop-simple-error "Hanging conditional in loop macro" - (caadar *loop-conditionals*))) + (loop-simple-error "Hanging conditional in loop macro" + (caadar *loop-conditionals*))) (loop-optimize-duplicated-code-etc) (loop-bind-block) (and *loop-desetq-temporary* (push *loop-desetq-temporary* progvars)) (setq tem `(block ,(car *loop-prog-names*) - (let ,progvars - (tagbody - ,@(nreverse *loop-prologue*) - ,@*loop-before-loop* - next-loop - ,@*loop-body* - ,@*loop-after-body* - (go next-loop) - (go end-loop) - end-loop - ,@(nreverse *loop-epilogue*) - ,@(nreverse *loop-after-epilogue*))))) + (let ,progvars + (tagbody + ,@(nreverse *loop-prologue*) + ,@*loop-before-loop* + next-loop + ,@*loop-body* + ,@*loop-after-body* + (go next-loop) + (go end-loop) + end-loop + ,@(nreverse *loop-epilogue*) + ,@(nreverse *loop-after-epilogue*))))) (do ((vars) (dcls) (crocks)) - ((null *loop-variable-stack*)) - (setq vars (car *loop-variable-stack*) - *loop-variable-stack* (cdr *loop-variable-stack*) - dcls (car *loop-declaration-stack*) - *loop-declaration-stack* (cdr *loop-declaration-stack*) - tem (list tem)) - (and (setq crocks (pop *loop-desetq-stack*)) - (push (loop-make-desetq crocks) tem)) - (and dcls (push (cons 'declare dcls) tem)) - ;; JJGR -- Avoid building LAMBDAs as far as possible - (setq tem `(let ,(nreverse vars) ,@tem)) - #+nil - (cond ((do ((l vars (cdr l))) ((null l) nil) - (and (not (atom (car l))) - (or (null (caar l)) (not (symbolp (caar l)))) - (return t))) - (setq tem `(let ,(nreverse vars) ,@tem))) - (t (let ((lambda-vars nil) (lambda-vals nil)) - (do ((l vars (cdr l)) (v)) ((null l)) - (cond ((atom (setq v (car l))) - (push v lambda-vars) - (push nil lambda-vals)) - (t (push (car v) lambda-vars) - (push (cadr v) lambda-vals)))) - (setq tem `((lambda ,lambda-vars ,@tem) - ,@lambda-vals)))))) + ((null *loop-variable-stack*)) + (setq vars (car *loop-variable-stack*) + *loop-variable-stack* (cdr *loop-variable-stack*) + dcls (car *loop-declaration-stack*) + *loop-declaration-stack* (cdr *loop-declaration-stack*) + tem (list tem)) + (and (setq crocks (pop *loop-desetq-stack*)) + (push (loop-make-desetq crocks) tem)) + (and dcls (push (cons 'declare dcls) tem)) + ;; JJGR -- Avoid building LAMBDAs as far as possible + (setq tem `(let ,(nreverse vars) ,@tem)) + #+nil + (cond ((do ((l vars (cdr l))) ((null l) nil) + (and (not (atom (car l))) + (or (null (caar l)) (not (symbolp (caar l)))) + (return t))) + (setq tem `(let ,(nreverse vars) ,@tem))) + (t (let ((lambda-vars nil) (lambda-vals nil)) + (do ((l vars (cdr l)) (v)) ((null l)) + (cond ((atom (setq v (car l))) + (push v lambda-vars) + (push nil lambda-vals)) + (t (push (car v) lambda-vars) + (push (cadr v) lambda-vals)))) + (setq tem `((lambda ,lambda-vars ,@tem) + ,@lambda-vals)))))) (do ((l *loop-wrappers* (cdr l))) ((null l)) - (setq tem (append (car l) (list tem)))) + (setq tem (append (car l) (list tem)))) tem) ;;The following commented-out code is what comes from the newest source ;; code in use in NIL. The code in use following it comes from about version ;; 803, that in use in symbolics release 6.1, for instance. To turn on the ;; implicit DO feature, switch them and fix loop-get-form to just pop the source. (if (symbolp (setq keyword (car *loop-source-code*))) - (loop-pop-source) + (loop-pop-source) (setq keyword 'do)) (cond ((setq tem (loop-tassoc keyword +loop-keyword-alist+)) - (apply (cadr tem) (cddr tem))) - ((setq tem (loop-tassoc keyword +loop-iteration-keyword-alist+)) - (loop-hack-iteration tem)) - ((loop-tmember keyword '(and else)) - ;; Alternative is to ignore it, ie let it go around to the - ;; next keyword... - (loop-simple-error - "secondary clause misplaced at top level in LOOP macro" - (list keyword (car *loop-source-code*) - (cadr *loop-source-code*)))) - (t (loop-simple-error "unknown keyword in LOOP macro" keyword))) + (apply (cadr tem) (cddr tem))) + ((setq tem (loop-tassoc keyword +loop-iteration-keyword-alist+)) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; Alternative is to ignore it, ie let it go around to the + ;; next keyword... + (loop-simple-error + "secondary clause misplaced at top level in LOOP macro" + (list keyword (car *loop-source-code*) + (cadr *loop-source-code*)))) + (t (loop-simple-error "unknown keyword in LOOP macro" keyword))) ;; (if (symbolp (setq keyword (loop-pop-source))) - ;; (if (setq tem (loop-tassoc keyword +loop-keyword-alist+)) - ;; (apply (cadr tem) (cddr tem)) - ;; (if (setq tem (loop-tassoc - ;; keyword +loop-iteration-keyword-alist+)) - ;; (loop-hack-iteration tem) - ;; (if (loop-tmember keyword '(and else)) - ;; ; Alternative is to ignore it, ie let it go around to the - ;; ; next keyword... - ;; (loop-simple-error - ;; "secondary clause misplaced at top level in LOOP macro" - ;; (list keyword (car *loop-source-code*) - ;; (cadr *loop-source-code*))) - ;; (loop-simple-error - ;; "unknown keyword in LOOP macro" keyword)))) - ;; (loop-simple-error - ;; "found where keyword expected in LOOP macro" keyword)) + ;; (if (setq tem (loop-tassoc keyword +loop-keyword-alist+)) + ;; (apply (cadr tem) (cddr tem)) + ;; (if (setq tem (loop-tassoc + ;; keyword +loop-iteration-keyword-alist+)) + ;; (loop-hack-iteration tem) + ;; (if (loop-tmember keyword '(and else)) + ;; ; Alternative is to ignore it, ie let it go around to the + ;; ; next keyword... + ;; (loop-simple-error + ;; "secondary clause misplaced at top level in LOOP macro" + ;; (list keyword (car *loop-source-code*) + ;; (cadr *loop-source-code*))) + ;; (loop-simple-error + ;; "unknown keyword in LOOP macro" keyword)))) + ;; (loop-simple-error + ;; "found where keyword expected in LOOP macro" keyword)) )) (defun loop-bind-block () (cond ((not (null *loop-variables*)) - (push *loop-variables* *loop-variable-stack*) - (push *loop-declarations* *loop-declaration-stack*) - (setq *loop-variables* nil *loop-declarations* nil) - (push *loop-desetq-crocks* *loop-desetq-stack*) - (setq *loop-desetq-crocks* nil)))) + (push *loop-variables* *loop-variable-stack*) + (push *loop-declarations* *loop-declaration-stack*) + (setq *loop-variables* nil *loop-declarations* nil) + (push *loop-desetq-crocks* *loop-desetq-stack*) + (setq *loop-desetq-crocks* nil)))) ;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary. @@ -548,14 +548,14 @@ collected result will be returned as the value of the LOOP." ;; just loop-pop-source. (let ((forms (loop-get-progn-1))) (cond ((null (cdr forms)) (car forms)) - (t (loop-warn + (t (loop-warn "The use of multiple forms with an implicit PROGN in this context is considered obsolete, but is still supported for the time being. If you did not intend to use multiple forms here, you probably omitted a DO. If the use of multiple forms was intentional, put a PROGN in your code. The offending clause" - (if (atom for) (cons for forms) (append for forms))) - (cons 'progn forms))))) + (if (atom for) (cons for forms) (append for forms))) + (cons 'progn forms))))) ;;;This function takes a substitutable expression containing generic arithmetic @@ -566,56 +566,56 @@ The offending clause" substitutable-expression) (defparameter loop-floating-point-types - '(flonum float short-float single-float double-float long-float)) + '(flonum float short-float single-float double-float long-float)) (defun loop-typed-init (data-type) (let ((tem nil)) (cond ((loop-tmember data-type '(fixnum integer number)) 0) - ((setq tem (car (loop-tmember - data-type loop-floating-point-types))) - (cond ((member tem '(flonum float)) 0.0) - (t (coerce 0 tem))))))) + ((setq tem (car (loop-tmember + data-type loop-floating-point-types))) + (cond ((member tem '(flonum float)) 0.0) + (t (coerce 0 tem))))))) (defun loop-make-variable (name initialization dtype) (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (loop-gentemp 'loop-ignore-)) - initialization) - *loop-variables*) - (push `(ignore ,name) *loop-declarations*)))) - ((atom name) - (cond (*loop-iteration-variablep* - (if (member name *loop-iteration-variables*) - (loop-simple-error - "Duplicated iteration variable somewhere in LOOP" - name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) - (loop-simple-error - "Duplicated var in LOOP bind block" name))) - (or (symbolp name) - (loop-simple-error "Bad variable somewhere in LOOP" name)) - (loop-declare-variable name dtype) - ; 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))) - *loop-variables*)) - (initialization - (cond (*loop-use-system-destructuring?* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (loop-gentemp 'loop-destructure-))) - (push (list newvar initialization) *loop-variables*) - ; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)) - (loop-make-variable name nil dtype))))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar) - (loop-make-variable (cdr name) nil tcdr)))) + (cond ((not (null initialization)) + (push (list (setq name (loop-gentemp 'loop-ignore-)) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (*loop-iteration-variablep* + (if (member name *loop-iteration-variables*) + (loop-simple-error + "Duplicated iteration variable somewhere in LOOP" + name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-simple-error + "Duplicated var in LOOP bind block" name))) + (or (symbolp name) + (loop-simple-error "Bad variable somewhere in LOOP" name)) + (loop-declare-variable name dtype) + ; 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))) + *loop-variables*)) + (initialization + (cond (*loop-use-system-destructuring?* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (push (list newvar initialization) *loop-variables*) + ; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)) + (loop-make-variable name nil dtype))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar) + (loop-make-variable (cdr name) nil tcdr)))) name) @@ -626,17 +626,17 @@ The offending clause" (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype)) nil) - ((and (symbolp name) (not (member name *loop-nodeclare*))) - (push `(type ,(if (loop-tequal dtype 'notype) t dtype) ,name) - *loop-declarations*)) - ((consp name) - (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype)) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype) - (loop-declare-variable (cdr name) dtype)))) - (t (loop-simple-error "can't hack this" - (list 'loop-declare-variable name dtype))))) + ((and (symbolp name) (not (member name *loop-nodeclare*))) + (push `(type ,(if (loop-tequal dtype 'notype) t dtype) ,name) + *loop-declarations*)) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (loop-simple-error "can't hack this" + (list 'loop-declare-variable name dtype))))) (defun loop-constantp (form) @@ -651,57 +651,57 @@ The offending clause" ; matter are the ones that use it as a stepper (or whatever), which ; handle it specially. (if (loop-constantp form) form - (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?))) + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?))) (defun loop-optional-type () (let ((token (car *loop-source-code*))) - (and (not (null token)) - (or (not (atom token)) - (loop-tmember token '(fixnum integer number notype)) - (loop-tmember token loop-floating-point-types)) - (loop-pop-source)))) + (and (not (null token)) + (or (not (atom token)) + (loop-tmember token '(fixnum integer number notype)) + (loop-tmember token loop-floating-point-types)) + (loop-pop-source)))) ;Incorporates conditional if necessary (defun loop-make-conditionalization (form) (cond ((not (null *loop-conditionals*)) - (rplacd (last (car (last (car (last *loop-conditionals*))))) - (list form)) - (cond ((loop-tequal (car *loop-source-code*) 'and) - (loop-pop-source) - nil) - ((loop-tequal (car *loop-source-code*) 'else) - (loop-pop-source) - ;; If we are already inside an else clause, close it off - ;; and nest it inside the containing when clause - (let ((innermost (car (last *loop-conditionals*)))) - (cond ((null (cddr innermost))) ;Now in a WHEN clause, OK - ((null (cdr *loop-conditionals*)) - (loop-simple-error "More ELSEs than WHENs" - (list 'else (car *loop-source-code*) - (cadr *loop-source-code*)))) - (t (setq *loop-conditionals* (cdr (nreverse *loop-conditionals*))) - (rplacd (last (car (last (car *loop-conditionals*)))) - (list innermost)) - (setq *loop-conditionals* (nreverse *loop-conditionals*))))) - ;; Start a new else clause - (rplacd (last (car (last *loop-conditionals*))) - (list (list 't))) - nil) - (t ;Nest up the conditionals and output them - (do ((prev (car *loop-conditionals*) (car l)) - (l (cdr *loop-conditionals*) (cdr l))) - ((null l)) - (rplacd (last (car (last prev))) (list (car l)))) - (prog1 (car *loop-conditionals*) - (setq *loop-conditionals* nil))))) - (t form))) + (rplacd (last (car (last (car (last *loop-conditionals*))))) + (list form)) + (cond ((loop-tequal (car *loop-source-code*) 'and) + (loop-pop-source) + nil) + ((loop-tequal (car *loop-source-code*) 'else) + (loop-pop-source) + ;; If we are already inside an else clause, close it off + ;; and nest it inside the containing when clause + (let ((innermost (car (last *loop-conditionals*)))) + (cond ((null (cddr innermost))) ;Now in a WHEN clause, OK + ((null (cdr *loop-conditionals*)) + (loop-simple-error "More ELSEs than WHENs" + (list 'else (car *loop-source-code*) + (cadr *loop-source-code*)))) + (t (setq *loop-conditionals* (cdr (nreverse *loop-conditionals*))) + (rplacd (last (car (last (car *loop-conditionals*)))) + (list innermost)) + (setq *loop-conditionals* (nreverse *loop-conditionals*))))) + ;; Start a new else clause + (rplacd (last (car (last *loop-conditionals*))) + (list (list 't))) + nil) + (t ;Nest up the conditionals and output them + (do ((prev (car *loop-conditionals*) (car l)) + (l (cdr *loop-conditionals*) (cdr l))) + ((null l)) + (rplacd (last (car (last prev))) (list (car l)))) + (prog1 (car *loop-conditionals*) + (setq *loop-conditionals* nil))))) + (t form))) (defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form))) (cond ((not (null z)) - (cond (*loop-emitted-body?* (push z *loop-body*)) - (t (push z *loop-before-loop*) (push z *loop-after-body*)))))) + (cond (*loop-emitted-body?* (push z *loop-body*)) + (t (push z *loop-before-loop*) (push z *loop-after-body*)))))) (defun loop-emit-body (form) (setq *loop-emitted-body?* t) @@ -718,15 +718,15 @@ The offending clause" (loop-simple-error "NAMED clause occurs too late" name)) (when (cdr (setq *loop-prog-names* (cons name *loop-prog-names*))) (loop-simple-error "Too many names for your loop construct" - *loop-prog-names*)))) + *loop-prog-names*)))) (defun loop-do-initially () (push (loop-get-progn) *loop-prologue*)) (defun loop-nodeclare (&aux (varlist (loop-pop-source))) (or (null varlist) - (consp varlist) - (loop-simple-error "Bad varlist to nodeclare loop clause" varlist)) + (consp varlist) + (loop-simple-error "Bad varlist to nodeclare loop clause" varlist)) (setq *loop-nodeclare* (append varlist *loop-nodeclare*))) (defun loop-do-finally () @@ -741,104 +741,104 @@ The offending clause" (defun loop-do-collect (type) (let ((var nil) (form nil) (tem nil) (tail nil) (dtype nil) (cruft nil) (rvar nil) - (ctype (case type - ((max min) 'maxmin) - ((nconc list append) 'list) - ((count sum) 'sum) - (t (error "LOOP internal error: ~S is an unknown collecting keyword." - type))))) + (ctype (case type + ((max min) 'maxmin) + ((nconc list append) 'list) + ((count sum) 'sum) + (t (error "LOOP internal error: ~S is an unknown collecting keyword." + type))))) (setq form (loop-get-form type) dtype (loop-optional-type)) (cond ((loop-tequal (car *loop-source-code*) 'into) - (loop-pop-source) - (setq rvar (setq var (loop-pop-source))))) + (loop-pop-source) + (setq rvar (setq var (loop-pop-source))))) ; CRUFT will be (varname ctype dtype var tail (optional tem)) (cond ((setq cruft (assoc var *loop-collect-cruft*)) - (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) - (loop-simple-error - "incompatible LOOP collection types" - (list ctype (car cruft)))) - ((and dtype (not (eq dtype (cadr cruft)))) - ;Conditional should be on data-type reality - (error "~A and ~A Unequal data types into ~A" - dtype (cadr cruft) (car cruft)))) - (setq dtype (car (setq cruft (cdr cruft))) - var (car (setq cruft (cdr cruft))) - tail (car (setq cruft (cdr cruft))) - tem (cadr cruft)) - (and (eq ctype 'maxmin) - (not (atom form)) (null tem) - (rplaca (cdr cruft) - (setq tem (loop-make-variable - (loop-gentemp 'loop-maxmin-) - nil dtype))))) - (t (unless dtype - (setq dtype (case type - (count 'fixnum) - ((min max sum) 'number)))) - (unless var - (push (loop-construct-return (setq var (loop-gentemp))) - *loop-after-epilogue*)) - (loop-make-iteration-variable var nil dtype) - (cond ((eq ctype 'maxmin) - ;Make a temporary. - (unless (atom form) - (setq tem (loop-make-variable - (loop-gentemp) nil dtype))) - ;Use the tail slot of the collect database to hold a - ; flag which says we have been around once already. - (setq tail (loop-make-variable - (loop-gentemp 'loop-maxmin-fl-) t nil))) - ((eq ctype 'list) - ;For dumb collection, we need both a tail and a flag var - ; to tell us whether we have iterated. - (setq tail (loop-make-variable (loop-gentemp) nil nil) - tem (loop-make-variable (loop-gentemp) nil nil)))) - (push (list rvar ctype dtype var tail tem) - *loop-collect-cruft*))) + (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) + (loop-simple-error + "incompatible LOOP collection types" + (list ctype (car cruft)))) + ((and dtype (not (eq dtype (cadr cruft)))) + ;Conditional should be on data-type reality + (error "~A and ~A Unequal data types into ~A" + dtype (cadr cruft) (car cruft)))) + (setq dtype (car (setq cruft (cdr cruft))) + var (car (setq cruft (cdr cruft))) + tail (car (setq cruft (cdr cruft))) + tem (cadr cruft)) + (and (eq ctype 'maxmin) + (not (atom form)) (null tem) + (rplaca (cdr cruft) + (setq tem (loop-make-variable + (loop-gentemp 'loop-maxmin-) + nil dtype))))) + (t (unless dtype + (setq dtype (case type + (count 'fixnum) + ((min max sum) 'number)))) + (unless var + (push (loop-construct-return (setq var (loop-gentemp))) + *loop-after-epilogue*)) + (loop-make-iteration-variable var nil dtype) + (cond ((eq ctype 'maxmin) + ;Make a temporary. + (unless (atom form) + (setq tem (loop-make-variable + (loop-gentemp) nil dtype))) + ;Use the tail slot of the collect database to hold a + ; flag which says we have been around once already. + (setq tail (loop-make-variable + (loop-gentemp 'loop-maxmin-fl-) t nil))) + ((eq ctype 'list) + ;For dumb collection, we need both a tail and a flag var + ; to tell us whether we have iterated. + (setq tail (loop-make-variable (loop-gentemp) nil nil) + tem (loop-make-variable (loop-gentemp) nil nil)))) + (push (list rvar ctype dtype var tail tem) + *loop-collect-cruft*))) (loop-emit-body - (case type - (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype) - ,var))) - (if (or (eq form t) (equal form ''t)) - tem - `(when ,form ,tem))) - (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var))) - ((max min) - (let ((forms nil) (arglist nil)) - ; TEM is temporary, properly typed. - (and tem (setq forms `((setq ,tem ,form)) form tem)) - (setq arglist (list var form)) - (push (if (loop-tmember dtype '(fixnum flonum)) - ; no contagious arithmetic - `(when (or ,tail - (,(loop-typed-arith - (if (eq type 'max) '< '>) - dtype) - ,@arglist)) - (setq ,tail nil ,@arglist)) - ; potentially contagious arithmetic -- must use - ; MAX or MIN so that var will be contaminated - `(setq ,var (cond (,tail (setq ,tail nil) ,form) - (t (,type ,@arglist))))) - forms) - (if (cdr forms) (cons 'progn (nreverse forms)) (car forms)))) - (t (case type - (list (setq form (list 'list form))) - (append (or (and (not (atom form)) (eq (car form) 'list)) - (setq form `(copy-list ,form))))) - (let ((q `(if ,tail (cdr (rplacd ,tail ,tem)) - (setq ,var ,tem)))) - (if (and (not (atom form)) (eq (car form) 'list) (cdr form)) - `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q)) - `(when (setq ,tem ,form) (setq ,tail (last ,q)))))))))) + (case type + (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype) + ,var))) + (if (or (eq form t) (equal form ''t)) + tem + `(when ,form ,tem))) + (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var))) + ((max min) + (let ((forms nil) (arglist nil)) + ; TEM is temporary, properly typed. + (and tem (setq forms `((setq ,tem ,form)) form tem)) + (setq arglist (list var form)) + (push (if (loop-tmember dtype '(fixnum flonum)) + ; no contagious arithmetic + `(when (or ,tail + (,(loop-typed-arith + (if (eq type 'max) '< '>) + dtype) + ,@arglist)) + (setq ,tail nil ,@arglist)) + ; potentially contagious arithmetic -- must use + ; MAX or MIN so that var will be contaminated + `(setq ,var (cond (,tail (setq ,tail nil) ,form) + (t (,type ,@arglist))))) + forms) + (if (cdr forms) (cons 'progn (nreverse forms)) (car forms)))) + (t (case type + (list (setq form (list 'list form))) + (append (or (and (not (atom form)) (eq (car form) 'list)) + (setq form `(copy-list ,form))))) + (let ((q `(if ,tail (cdr (rplacd ,tail ,tem)) + (setq ,var ,tem)))) + (if (and (not (atom form)) (eq (car form) 'list) (cdr form)) + `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q)) + `(when (setq ,tem ,form) (setq ,tail (last ,q)))))))))) (defun loop-cdrify (arglist form) (do ((size (length arglist) (- size 4))) - ((< size 4) - (if (zerop size) form - (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr)) - form))) + ((< size 4) + (if (zerop size) form + (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr)) + form))) (declare (type fixnum size)) (setq form (list 'cddddr form)))) @@ -847,21 +847,21 @@ The offending clause" (defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd))) (when *loop-conditionals* (loop-simple-error "not allowed inside LOOP conditional" - (list kwd form))) + (list kwd form))) (loop-pseudo-body `(,(if negate? 'when 'unless) - ,form (go end-loop)))) + ,form (go end-loop)))) (defun loop-do-when (negate? kwd) (let ((form (loop-get-form kwd)) (cond nil)) (cond ((loop-tequal (cadr *loop-source-code*) 'it) - ;WHEN foo RETURN IT and the like - (setq cond `(setq ,(loop-when-it-variable) ,form)) - (setq *loop-source-code* ;Plug in variable for IT - (list* (car *loop-source-code*) - *loop-when-it-variable* - (cddr *loop-source-code*)))) - (t (setq cond form))) + ;WHEN foo RETURN IT and the like + (setq cond `(setq ,(loop-when-it-variable) ,form)) + (setq *loop-source-code* ;Plug in variable for IT + (list* (car *loop-source-code*) + *loop-when-it-variable* + (cddr *loop-source-code*)))) + (t (setq cond form))) (and negate? (setq cond `(not ,cond))) (setq *loop-conditionals* (nconc *loop-conditionals* `((cond (,cond))))))) @@ -869,40 +869,40 @@ The offending clause" (do ((var) (equals) (val) (dtype)) (nil) (setq var (loop-pop-source) equals (car *loop-source-code*)) (cond ((loop-tequal equals '=) - (loop-pop-source) - (setq val (loop-get-form (list 'with var '=)) dtype nil)) - ((or (loop-tequal equals 'and) - (loop-tassoc equals +loop-keyword-alist+) - (loop-tassoc equals +loop-iteration-keyword-alist+)) - (setq val nil dtype nil)) - (t (setq dtype (loop-optional-type) equals (car *loop-source-code*)) - (cond ((loop-tequal equals '=) - (loop-pop-source) - (setq val (loop-get-form (list 'with var dtype '=)))) - ((and (not (null *loop-source-code*)) - (not (loop-tassoc equals +loop-keyword-alist+)) - (not (loop-tassoc - equals +loop-iteration-keyword-alist+)) - (not (loop-tequal equals 'and))) - (loop-simple-error "Garbage where = expected" equals)) - (t (setq val nil))))) + (loop-pop-source) + (setq val (loop-get-form (list 'with var '=)) dtype nil)) + ((or (loop-tequal equals 'and) + (loop-tassoc equals +loop-keyword-alist+) + (loop-tassoc equals +loop-iteration-keyword-alist+)) + (setq val nil dtype nil)) + (t (setq dtype (loop-optional-type) equals (car *loop-source-code*)) + (cond ((loop-tequal equals '=) + (loop-pop-source) + (setq val (loop-get-form (list 'with var dtype '=)))) + ((and (not (null *loop-source-code*)) + (not (loop-tassoc equals +loop-keyword-alist+)) + (not (loop-tassoc + equals +loop-iteration-keyword-alist+)) + (not (loop-tequal equals 'and))) + (loop-simple-error "Garbage where = expected" equals)) + (t (setq val nil))))) (loop-make-variable var val dtype) (if (not (loop-tequal (car *loop-source-code*) 'and)) (return nil) - (loop-pop-source))) + (loop-pop-source))) (loop-bind-block)) (defun loop-do-always (negate?) (let ((form (loop-get-form 'always))) (loop-emit-body `(,(if negate? 'when 'unless) ,form - ,(loop-construct-return nil))) + ,(loop-construct-return nil))) (push (loop-construct-return t) *loop-after-epilogue*))) ;THEREIS expression ;If expression evaluates non-nil, return that value. (defun loop-do-thereis () (loop-emit-body `(when (setq ,(loop-when-it-variable) - ,(loop-get-form 'thereis)) - ,(loop-construct-return *loop-when-it-variable*)))) + ,(loop-get-form 'thereis)) + ,(loop-construct-return *loop-when-it-variable*)))) ;;;; Hacks @@ -910,49 +910,49 @@ The offending clause" (defun loop-simplep (expr) (if (null expr) 0 (catch 'loop-simplep - (let ((ans (loop-simplep-1 expr))) - (declare (fixnum ans)) - (and (< ans 20.) ans))))) + (let ((ans (loop-simplep-1 expr))) + (declare (fixnum ans)) + (and (< ans 20.) ans))))) (defparameter loop-simplep - '(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref)) + '(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref)) (defun loop-simplep-1 (x) (let ((z 0)) (declare (fixnum z)) (cond ((loop-constantp x) 0) - ((atom x) 1) - ((eq (car x) 'cond) - (do ((cl (cdr x) (cdr cl))) ((null cl)) - (do ((f (car cl) (cdr f))) ((null f)) - (setq z (+ (loop-simplep-1 (car f)) z 1)))) - z) - ((symbolp (car x)) - (let ((fn (car x)) (tem nil)) - (cond ((setq tem (get-sysprop fn 'loop-simplep)) - (if (typep tem 'fixnum) (setq z tem) - (setq z (funcall tem x) x nil))) - ((member fn '(null not eq go return progn))) - ((member fn '(car cdr)) (setq z 1)) - ((member fn '(caar cadr cdar cddr)) (setq z 2)) - ((member fn '(caaar caadr cadar caddr - cdaar cdadr cddar cdddr)) - (setq z 3)) - ((member fn '(caaaar caaadr caadar caaddr - cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr)) - (setq z 4)) - ((member fn loop-simplep) (setq z 2)) - (t (multiple-value-bind (new-form expanded-p) - (macroexpand-1 x *loop-macro-environment*) - (if expanded-p - (setq z (loop-simplep-1 new-form) x nil) - (throw 'loop-simplep nil))))) - (do ((l (cdr x) (cdr l))) ((null l)) - (setq z (+ (loop-simplep-1 (car l)) 1 z))) - z)) - (t (throw 'loop-simplep nil))))) + ((atom x) 1) + ((eq (car x) 'cond) + (do ((cl (cdr x) (cdr cl))) ((null cl)) + (do ((f (car cl) (cdr f))) ((null f)) + (setq z (+ (loop-simplep-1 (car f)) z 1)))) + z) + ((symbolp (car x)) + (let ((fn (car x)) (tem nil)) + (cond ((setq tem (get-sysprop fn 'loop-simplep)) + (if (typep tem 'fixnum) (setq z tem) + (setq z (funcall tem x) x nil))) + ((member fn '(null not eq go return progn))) + ((member fn '(car cdr)) (setq z 1)) + ((member fn '(caar cadr cdar cddr)) (setq z 2)) + ((member fn '(caaar caadr cadar caddr + cdaar cdadr cddar cdddr)) + (setq z 3)) + ((member fn '(caaaar caaadr caadar caaddr + cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr)) + (setq z 4)) + ((member fn loop-simplep) (setq z 2)) + (t (multiple-value-bind (new-form expanded-p) + (macroexpand-1 x *loop-macro-environment*) + (if expanded-p + (setq z (loop-simplep-1 new-form) x nil) + (throw 'loop-simplep nil))))) + (do ((l (cdr x) (cdr l))) ((null l)) + (setq z (+ (loop-simplep-1 (car l)) 1 z))) + z)) + (t (throw 'loop-simplep nil))))) ;;;; The iteration driver @@ -976,81 +976,81 @@ The offending clause" (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) (setq pseudo-steps - (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (and (or *loop-conditionals* *loop-emitted-body?*) - (or tem pre-step-tests post-step-tests pseudo-steps) - (let ((cruft (list (car entry) (car source) - (cadr source) (caddr source)))) - (if *loop-emitted-body?* - (loop-simple-error - "Iteration is not allowed to follow body code" cruft) - (loop-simple-error - "Iteration starting inside of conditional in LOOP" - cruft)))) + (or tem pre-step-tests post-step-tests pseudo-steps) + (let ((cruft (list (car entry) (car source) + (cadr source) (caddr source)))) + (if *loop-emitted-body?* + (loop-simple-error + "Iteration is not allowed to follow body code" cruft) + (loop-simple-error + "Iteration starting inside of conditional in LOOP" + cruft)))) (or tem (setq tem data)) (and (car tem) (push (car tem) pre-loop-pre-step-tests)) (setq pre-loop-steps - (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps - (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) + (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) (cond ((or (not (loop-tequal (car *loop-source-code*) 'and)) - (and *loop-conditionals* - (not (loop-tassoc (cadr *loop-source-code*) - +loop-iteration-keyword-alist+)))) - (setq foo (list (loop-end-testify pre-loop-pre-step-tests) - (loop-make-psetq pre-loop-steps) - (loop-end-testify pre-loop-post-step-tests) - (loop-make-setq pre-loop-pseudo-steps)) - bar (list (loop-end-testify pre-step-tests) - (loop-make-psetq steps) - (loop-end-testify post-step-tests) - (loop-make-setq pseudo-steps))) - (cond ((not *loop-conditionals*) - (setq *loop-before-loop* (nreconc foo *loop-before-loop*) - *loop-after-body* (nreconc bar *loop-after-body*))) - (t ((lambda (*loop-conditionals*) - (push (loop-make-conditionalization - (cons 'progn (delete nil foo))) - *loop-before-loop*)) - (mapcar #'(lambda (x) ;Copy parts that will get rplacd'ed - (cons (car x) - (mapcar #'(lambda (x) (loop-copylist* x)) (cdr x)))) - *loop-conditionals*)) - (push (loop-make-conditionalization - (cons 'progn (delete nil bar))) - *loop-after-body*))) - (loop-bind-block) - (return nil))) + (and *loop-conditionals* + (not (loop-tassoc (cadr *loop-source-code*) + +loop-iteration-keyword-alist+)))) + (setq foo (list (loop-end-testify pre-loop-pre-step-tests) + (loop-make-psetq pre-loop-steps) + (loop-end-testify pre-loop-post-step-tests) + (loop-make-setq pre-loop-pseudo-steps)) + bar (list (loop-end-testify pre-step-tests) + (loop-make-psetq steps) + (loop-end-testify post-step-tests) + (loop-make-setq pseudo-steps))) + (cond ((not *loop-conditionals*) + (setq *loop-before-loop* (nreconc foo *loop-before-loop*) + *loop-after-body* (nreconc bar *loop-after-body*))) + (t ((lambda (*loop-conditionals*) + (push (loop-make-conditionalization + (cons 'progn (delete nil foo))) + *loop-before-loop*)) + (mapcar #'(lambda (x) ;Copy parts that will get rplacd'ed + (cons (car x) + (mapcar #'(lambda (x) (loop-copylist* x)) (cdr x)))) + *loop-conditionals*)) + (push (loop-make-conditionalization + (cons 'progn (delete nil bar))) + *loop-after-body*))) + (loop-bind-block) + (return nil))) (loop-pop-source) ; flush the "AND" (setq entry (cond ((setq tem (loop-tassoc - (car *loop-source-code*) - +loop-iteration-keyword-alist+)) - (loop-pop-source) - (setq last-entry tem)) - (t last-entry))))) + (car *loop-source-code*) + +loop-iteration-keyword-alist+)) + (loop-pop-source) + (setq last-entry tem)) + (t last-entry))))) ;FOR variable keyword ..args.. (defun loop-do-for () (let ((var (loop-pop-source)) - (data-type? (loop-optional-type)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) + (data-type? (loop-optional-type)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) (setq first-arg (loop-get-form (list 'for var keyword))) (or (setq tem (loop-tassoc keyword +loop-for-keyword-alist+)) - (loop-simple-error - "Unknown keyword in FOR or AS clause in LOOP" - (list 'for var keyword))) + (loop-simple-error + "Unknown keyword in FOR or AS clause in LOOP" + (list 'for var keyword))) (apply (cadr tem) var first-arg data-type? (cddr tem)))) (defun loop-do-repeat () (let ((var (loop-make-variable - (loop-gentemp 'loop-repeat-) - (loop-get-form 'repeat) 'fixnum))) + (loop-gentemp 'loop-repeat-) + (loop-get-form 'repeat) 'fixnum))) `((not (,(loop-typed-arith 'plusp 'fixnum) ,var)) () () (,var (,(loop-typed-arith '1- 'fixnum) ,var))))) @@ -1059,29 +1059,29 @@ The offending clause" ; Kludge the First (defun loop-when-it-variable () (or *loop-when-it-variable* - (setq *loop-when-it-variable* - (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + (setq *loop-when-it-variable* + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) (defun loop-for-equals (var val data-type?) (cond ((loop-tequal (car *loop-source-code*) 'then) - ;FOR var = first THEN next - (loop-pop-source) - (loop-make-iteration-variable var val data-type?) - `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () () - () () () ())) - (t (loop-make-iteration-variable var nil data-type?) - (let ((varval (list var val))) - (cond (*loop-emitted-body?* - (loop-emit-body (loop-make-setq varval)) - '(() () () ())) - (`(() ,varval () ()))))))) + ;FOR var = first THEN next + (loop-pop-source) + (loop-make-iteration-variable var val data-type?) + `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () () + () () () ())) + (t (loop-make-iteration-variable var nil data-type?) + (let ((varval (list var val))) + (cond (*loop-emitted-body?* + (loop-emit-body (loop-make-setq varval)) + '(() () () ())) + (`(() ,varval () ()))))))) (defun loop-for-first (var val data-type?) (or (loop-tequal (car *loop-source-code*) 'then) - (loop-simple-error "found where THEN expected in FOR ... FIRST" - (car *loop-source-code*))) + (loop-simple-error "found where THEN expected in FOR ... FIRST" + (car *loop-source-code*))) (loop-pop-source) (loop-make-iteration-variable var nil data-type?) `(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () () @@ -1090,30 +1090,30 @@ The offending clause" (defun loop-list-stepper (var val data-type? fn) (let ((stepper (cond ((loop-tequal (car *loop-source-code*) 'by) - (loop-pop-source) - (loop-get-form (list 'for var - (if (eq fn 'car) 'in 'on) - val 'by))) - (t '(function cdr)))) - (var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil)) + (loop-pop-source) + (loop-get-form (list 'for var + (if (eq fn 'car) 'in 'on) + val 'by))) + (t '(function cdr)))) + (var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil)) (setq step (if (or (atom stepper) - (not (member (car stepper) '(quote function)))) - `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-))) - (list (cadr stepper)))) + (not (member (car stepper) '(quote function)))) + `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-))) + (list (cadr stepper)))) (cond ((and (atom var) - ;; (eq (car step) 'cdr) - (not fn)) - (setq var1 (loop-make-iteration-variable var val data-type?))) - (t (loop-make-iteration-variable var nil data-type?) - (setq var1 (loop-make-variable - (loop-gentemp 'loop-list-) val nil)) - (setq pseudo (list var (if fn (list fn var1) var1))))) + ;; (eq (car step) 'cdr) + (not fn)) + (setq var1 (loop-make-iteration-variable var val data-type?))) + (t (loop-make-iteration-variable var nil data-type?) + (setq var1 (loop-make-variable + (loop-gentemp 'loop-list-) val nil)) + (setq pseudo (list var (if fn (list fn var1) var1))))) (rplacd (last step) (list var1)) (and stepvar (loop-make-variable stepvar stepper nil)) (setq stepper (list var1 step) et `(null ,var1)) (if (not pseudo) `(() ,stepper ,et () () () ,et ()) - (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper) - `((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo))))) + (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper) + `((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo))))) (defun loop-for-arithmetic (var val data-type? kwd) @@ -1123,16 +1123,16 @@ The offending clause" (loop-sequencer var (or data-type? 'fixnum) nil nil nil nil nil nil `(for ,var ,kwd ,val) (cons (list kwd val) - (loop-gather-preps - '(from upfrom downfrom to upto downto above below by) - nil)))) + (loop-gather-preps + '(from upfrom downfrom to upto downto above below by) + nil)))) (defun loop-named-variable (name) (let ((tem (loop-tassoc name *loop-named-variables*))) (cond ((null tem) (loop-gentemp)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) - (cdr tem))))) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (cdr tem))))) ; Note: path functions are allowed to use loop-make-variable, hack @@ -1146,60 +1146,60 @@ The offending clause" ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2. (let ((tem nil) (inclusive? nil) (ipps nil) (each? nil) (attachment nil)) (if (or (loop-tequal val 'each) (loop-tequal val 'the)) - (setq each? 't val (car *loop-source-code*)) - (push val *loop-source-code*)) + (setq each? 't val (car *loop-source-code*)) + (push val *loop-source-code*)) (cond ((and (setq tem (loop-tassoc val *loop-path-keyword-alist*)) - (or each? (not (loop-tequal (cadr *loop-source-code*) - 'and)))) - ;; FOR var BEING {each} path {prep expr}..., but NOT - ;; FOR var BEING var-which-looks-like-path AND {ITS} ... - (loop-pop-source)) - (t (setq val (loop-get-form (list 'for var 'being))) - (cond ((loop-tequal (car *loop-source-code*) 'and) - ;; FOR var BEING value AND ITS path-or-ar - (or (null each?) - (loop-simple-error - "Malformed BEING EACH clause in LOOP" var)) - (setq ipps `((of ,val)) inclusive? t) - (loop-pop-source) - (or (loop-tmember (setq tem (loop-pop-source)) - '(its his her their each)) - (loop-simple-error - "found where ITS or EACH expected in LOOP path" - tem)) - (if (setq tem (loop-tassoc - (car *loop-source-code*) - *loop-path-keyword-alist*)) - (loop-pop-source) - (push (setq attachment - `(in ,(loop-get-form - `(for ,var being \.\.\. in)))) - ipps))) - ((not (setq tem (loop-tassoc - (car *loop-source-code*) - *loop-path-keyword-alist*))) - ; FOR var BEING {each} a-r ... - (setq ipps (list (setq attachment (list 'in val))))) - (t ; FOR var BEING {each} pathname ... - ; Here, VAL should be just PATHNAME. - (loop-pop-source))))) + (or each? (not (loop-tequal (cadr *loop-source-code*) + 'and)))) + ;; FOR var BEING {each} path {prep expr}..., but NOT + ;; FOR var BEING var-which-looks-like-path AND {ITS} ... + (loop-pop-source)) + (t (setq val (loop-get-form (list 'for var 'being))) + (cond ((loop-tequal (car *loop-source-code*) 'and) + ;; FOR var BEING value AND ITS path-or-ar + (or (null each?) + (loop-simple-error + "Malformed BEING EACH clause in LOOP" var)) + (setq ipps `((of ,val)) inclusive? t) + (loop-pop-source) + (or (loop-tmember (setq tem (loop-pop-source)) + '(its his her their each)) + (loop-simple-error + "found where ITS or EACH expected in LOOP path" + tem)) + (if (setq tem (loop-tassoc + (car *loop-source-code*) + *loop-path-keyword-alist*)) + (loop-pop-source) + (push (setq attachment + `(in ,(loop-get-form + `(for ,var being \.\.\. in)))) + ipps))) + ((not (setq tem (loop-tassoc + (car *loop-source-code*) + *loop-path-keyword-alist*))) + ; FOR var BEING {each} a-r ... + (setq ipps (list (setq attachment (list 'in val))))) + (t ; FOR var BEING {each} pathname ... + ; Here, VAL should be just PATHNAME. + (loop-pop-source))))) (cond ((not (null tem))) - ((not (setq tem (loop-tassoc 'default-loop-path - *loop-path-keyword-alist*))) - (loop-simple-error "Undefined LOOP iteration path" - (cadr attachment)))) + ((not (setq tem (loop-tassoc 'default-loop-path + *loop-path-keyword-alist*))) + (loop-simple-error "Undefined LOOP iteration path" + (cadr attachment)))) (setq tem (funcall (cadr tem) (car tem) var data-type? - (nreconc ipps (loop-gather-preps (caddr tem) t)) - inclusive? (caddr tem) (cdddr tem))) + (nreconc ipps (loop-gather-preps (caddr tem) t)) + inclusive? (caddr tem) (cdddr tem))) (and *loop-named-variables* - (loop-simple-error "unused USING variables" *loop-named-variables*)) + (loop-simple-error "unused USING variables" *loop-named-variables*)) ; For error continuability (if there is any): (setq *loop-named-variables* nil) ;; TEM is now (bindings prologue-forms . stuff-to-pass-back) (do ((l (car tem) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) - (loop-make-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr tem)) *loop-prologue*)) (cddr tem))) @@ -1208,38 +1208,38 @@ The offending clause" (do ((token (car *loop-source-code*) (car *loop-source-code*)) (preps nil)) (nil) (cond ((loop-tmember token preps-allowed) - (push (list (loop-pop-source) - (loop-get-form `(for \... being \... ,token))) - preps)) - ((loop-tequal token 'using) - (loop-pop-source) - (or crockp (loop-simple-error - "USING used in illegal context" - (list 'using (car *loop-source-code*)))) - (do ((z (car *loop-source-code*) (car *loop-source-code*)) (tem)) - ((atom z)) - (and (or (atom (cdr z)) - (not (null (cddr z))) - (not (symbolp (car z))) - (and (cadr z) (not (symbolp (cadr z))))) - (loop-simple-error - "bad variable pair in path USING phrase" z)) - (cond ((not (null (cadr z))) - (and (setq tem (loop-tassoc - (car z) *loop-named-variables*)) - (loop-simple-error - "Duplicated var substitition in USING phrase" - (list tem z))) - (push (cons (car z) (cadr z)) *loop-named-variables*))) - (loop-pop-source))) - (t (return (nreverse preps)))))) + (push (list (loop-pop-source) + (loop-get-form `(for \... being \... ,token))) + preps)) + ((loop-tequal token 'using) + (loop-pop-source) + (or crockp (loop-simple-error + "USING used in illegal context" + (list 'using (car *loop-source-code*)))) + (do ((z (car *loop-source-code*) (car *loop-source-code*)) (tem)) + ((atom z)) + (and (or (atom (cdr z)) + (not (null (cddr z))) + (not (symbolp (car z))) + (and (cadr z) (not (symbolp (cadr z))))) + (loop-simple-error + "bad variable pair in path USING phrase" z)) + (cond ((not (null (cadr z))) + (and (setq tem (loop-tassoc + (car z) *loop-named-variables*)) + (loop-simple-error + "Duplicated var substitition in USING phrase" + (list tem z))) + (push (cons (car z) (cadr z)) *loop-named-variables*))) + (loop-pop-source))) + (t (return (nreverse preps)))))) (defun loop-add-path (name data) (setq *loop-path-keyword-alist* - (cons (cons name data) - (delete (loop-tassoc name *loop-path-keyword-alist*) - *loop-path-keyword-alist* - :test #'eq))) + (cons (cons name data) + (delete (loop-tassoc name *loop-path-keyword-alist*) + *loop-path-keyword-alist* + :test #'eq))) nil) @@ -1252,102 +1252,102 @@ contains a list of prepositions allowed in NAMES. DATUM-i are optional; they are passed on to PATH-FUNCTION as a list." (setq names (if (atom names) (list names) names)) (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft)) - names))) + names))) `(eval-when (eval load compile) ,@forms))) (defun loop-sequencer (indexv indexv-type - variable? vtype? - sequencev? sequence-type? - stephack? default-top? - crap prep-phrases) + variable? vtype? + sequencev? sequence-type? + stephack? default-top? + crap prep-phrases) (let ((endform nil) (sequencep nil) (test nil) - (step ; Gross me out! - (1+ (or (loop-typed-init indexv-type) 0))) - (dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil)) + (step ; Gross me out! + (1+ (or (loop-typed-init indexv-type) 0))) + (dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil)) (and variable? (loop-make-iteration-variable variable? nil vtype?)) (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) (setq prep (caar l) form (cadar l)) (cond ((loop-tmember prep '(of in)) - (and sequencep (loop-simple-error - "Sequence duplicated in LOOP path" - (list variable? (car l)))) - (setq sequencep t) - (loop-make-variable sequencev? form sequence-type?)) - ((loop-tmember prep '(from downfrom upfrom)) - (and start-given? - (loop-simple-error - "Iteration start redundantly specified in LOOP sequencing" - (append crap l))) - (setq start-given? t) - (cond ((loop-tequal prep 'downfrom) (setq dir 'down)) - ((loop-tequal prep 'upfrom) (setq dir 'up))) - (loop-make-iteration-variable indexv form indexv-type)) - ((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))) - (and limit-given? - (loop-simple-error - "Endtest redundantly specified in LOOP sequencing path" - (append crap l))) - (setq limit-given? t) - (setq endform (loop-maybe-bind-form form indexv-type))) - ((loop-tequal prep 'by) - (setq step (if (loop-constantp form) form - (loop-make-variable - (loop-gentemp 'loop-step-by-) - form 'fixnum)))) - (t ; This is a fatal internal error... - (loop-simple-error "Illegal prep in sequence path" - (append crap l)))) + (and sequencep (loop-simple-error + "Sequence duplicated in LOOP path" + (list variable? (car l)))) + (setq sequencep t) + (loop-make-variable sequencev? form sequence-type?)) + ((loop-tmember prep '(from downfrom upfrom)) + (and start-given? + (loop-simple-error + "Iteration start redundantly specified in LOOP sequencing" + (append crap l))) + (setq start-given? t) + (cond ((loop-tequal prep 'downfrom) (setq dir 'down)) + ((loop-tequal prep 'upfrom) (setq dir 'up))) + (loop-make-iteration-variable indexv form indexv-type)) + ((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))) + (and limit-given? + (loop-simple-error + "Endtest redundantly specified in LOOP sequencing path" + (append crap l))) + (setq limit-given? t) + (setq endform (loop-maybe-bind-form form indexv-type))) + ((loop-tequal prep 'by) + (setq step (if (loop-constantp form) form + (loop-make-variable + (loop-gentemp 'loop-step-by-) + form 'fixnum)))) + (t ; This is a fatal internal error... + (loop-simple-error "Illegal prep in sequence path" + (append crap l)))) (and odir dir (not (eq dir odir)) - (loop-simple-error - "Conflicting stepping directions in LOOP sequencing path" - (append crap l))) + (loop-simple-error + "Conflicting stepping directions in LOOP sequencing path" + (append crap l))) (setq odir dir)) (and sequencev? (not sequencep) - (loop-simple-error "Missing OF phrase in sequence path" crap)) + (loop-simple-error "Missing OF phrase in sequence path" crap)) ; Now fill in the defaults. (setq step (list indexv step)) (cond ((member dir '(nil up)) - (or start-given? - (loop-make-iteration-variable indexv 0 indexv-type)) - (and (or limit-given? - (cond (default-top? - (loop-make-variable - (setq endform (loop-gentemp - 'loop-seq-limit-)) - nil indexv-type) - (push `(setq ,endform ,default-top?) - *loop-prologue*)))) - (setq test (if inclusive-iteration? '(> . args) - '(>= . args)))) - (push '+ step)) - (t (cond ((not start-given?) - (or default-top? - (loop-simple-error - "Don't know where to start stepping" - (append crap prep-phrases))) - (loop-make-iteration-variable indexv 0 indexv-type) - (push `(setq ,indexv - (,(loop-typed-arith '1- indexv-type) - ,default-top?)) - *loop-prologue*))) - (cond ((and default-top? (not endform)) - (setq endform (loop-typed-init indexv-type) - inclusive-iteration? t))) - (and (not (null endform)) - (setq test (if inclusive-iteration? '(< . args) - '(<= . args)))) - (push '- step))) - (and (and (numberp (caddr step)) (= (caddr step) 1)) ;Generic arith - (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-))) - nil)) + (or start-given? + (loop-make-iteration-variable indexv 0 indexv-type)) + (and (or limit-given? + (cond (default-top? + (loop-make-variable + (setq endform (loop-gentemp + 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top?) + *loop-prologue*)))) + (setq test (if inclusive-iteration? '(> . args) + '(>= . args)))) + (push '+ step)) + (t (cond ((not start-given?) + (or default-top? + (loop-simple-error + "Don't know where to start stepping" + (append crap prep-phrases))) + (loop-make-iteration-variable indexv 0 indexv-type) + (push `(setq ,indexv + (,(loop-typed-arith '1- indexv-type) + ,default-top?)) + *loop-prologue*))) + (cond ((and default-top? (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration? t))) + (and (not (null endform)) + (setq test (if inclusive-iteration? '(< . args) + '(<= . args)))) + (push '- step))) + (and (and (numberp (caddr step)) (= (caddr step) 1)) ;Generic arith + (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-))) + nil)) (rplaca step (loop-typed-arith (car step) indexv-type)) (setq step (list indexv step)) (setq test (loop-typed-arith test indexv-type)) @@ -1358,32 +1358,32 @@ they are passed on to PATH-FUNCTION as a list." (defun loop-sequence-elements-path (path variable data-type - prep-phrases inclusive? - allowed-preps data) + prep-phrases inclusive? + allowed-preps data) allowed-preps ; unused (let ((indexv (loop-named-variable 'index)) - (sequencev (loop-named-variable 'sequence)) - (fetchfun nil) (sizefun nil) (type nil) (default-var-type nil) - (crap `(for ,variable being the ,path))) + (sequencev (loop-named-variable 'sequence)) + (fetchfun nil) (sizefun nil) (type nil) (default-var-type nil) + (crap `(for ,variable being the ,path))) (cond ((not (null inclusive?)) - (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path)) - (loop-simple-error "Can't step sequence inclusively" crap))) + (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path)) + (loop-simple-error "Can't step sequence inclusively" crap))) (setq fetchfun (car data) - sizefun (car (setq data (cdr data))) - type (car (setq data (cdr data))) - default-var-type (cadr data)) + sizefun (car (setq data (cdr data))) + type (car (setq data (cdr data))) + default-var-type (cadr data)) (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum - variable (or data-type default-var-type) - sequencev type - `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev) - crap prep-phrases)))) + (loop-sequencer + indexv 'fixnum + variable (or data-type default-var-type) + sequencev type + `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev) + crap prep-phrases)))) (defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun - &optional sequence-type element-type) + &optional sequence-type element-type) "Defines a sequence iiteration path. PATH-NAME-OR-NAMES is either an atomic path name or a list of path names. FETCHFUN is a function of two arguments, the sequence and the index of the item to be fetched. @@ -1393,43 +1393,43 @@ the sequence. SEQUENCE-TYPE is the name of the data-type of the sequence, and ELEMENT-TYPE is the name of the data-type of the elements of the sequence." `(define-loop-path ,path-name-or-names - loop-sequence-elements-path - (of in from downfrom to downto below above by) - ,fetchfun ,sizefun ,sequence-type ,element-type)) + loop-sequence-elements-path + (of in from downfrom to downto below above by) + ,fetchfun ,sizefun ,sequence-type ,element-type)) ;;;; Setup stuff (mapc #'(lambda (x) - (mapc #'(lambda (y) - (setq *loop-path-keyword-alist* - (cons `(,y loop-sequence-elements-path - (of in from downfrom to downto - below above by) - ,@(cdr x)) - (delete (loop-tassoc - y *loop-path-keyword-alist*) - *loop-path-keyword-alist* - :test #'eq :count 1)))) - (car x))) + (mapc #'(lambda (y) + (setq *loop-path-keyword-alist* + (cons `(,y loop-sequence-elements-path + (of in from downfrom to downto + below above by) + ,@(cdr x)) + (delete (loop-tassoc + y *loop-path-keyword-alist*) + *loop-path-keyword-alist* + :test #'eq :count 1)))) + (car x))) '( ((element elements) elt length sequence) - ;The following should be done by using ELEMENTS and type dcls... - ((vector-element - vector-elements - array-element ;; Backwards compatibility -- DRM - array-elements) - aref length vector) - ((simple-vector-element simple-vector-elements - simple-general-vector-element simple-general-vector-elements) - svref simple-vector-length simple-vector) - ((bits bit bit-vector-element bit-vector-elements) - bit bit-vector-length bit-vector bit) - ((simple-bit-vector-element simple-bit-vector-elements) - sbit simple-bit-vector-length simple-bit-vector bit) - ((character characters string-element string-elements) - char string-length string base-char) - ((simple-string-element simple-string-elements) - schar simple-string-length simple-string base-char) - ) + ;The following should be done by using ELEMENTS and type dcls... + ((vector-element + vector-elements + array-element ;; Backwards compatibility -- DRM + array-elements) + aref length vector) + ((simple-vector-element simple-vector-elements + simple-general-vector-element simple-general-vector-elements) + svref simple-vector-length simple-vector) + ((bits bit bit-vector-element bit-vector-elements) + bit bit-vector-length bit-vector bit) + ((simple-bit-vector-element simple-bit-vector-elements) + sbit simple-bit-vector-length simple-bit-vector bit) + ((character characters string-element string-elements) + char string-length string base-char) + ((simple-string-element simple-string-elements) + schar simple-string-length simple-string base-char) + ) ) diff --git a/src/lsp/loop2.lsp b/src/lsp/loop2.lsp index 4ce5f5df9..eca83a9fb 100755 --- a/src/lsp/loop2.lsp +++ b/src/lsp/loop2.lsp @@ -84,53 +84,53 @@ (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) - &body body) + &body body) (let ((l (and user-head-var (list (list user-head-var nil))))) `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) ,@body))) (defmacro loop-collect-rplacd (&environment env - (head-var tail-var &optional user-head-var) form) + (head-var tail-var &optional user-head-var) form) (setq form (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 if 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)))) (defmacro loop-collect-answer (head-var &optional user-head-var) @@ -157,10 +157,10 @@ constructed. (defstruct (loop-minimax - #+ecl (:type vector) - (:constructor make-loop-minimax-internal) - #+nil (:copier nil) - #+nil (:predicate nil)) + #+ecl (:type vector) + (:constructor make-loop-minimax-internal) + #+nil (:copier nil) + #+nil (:predicate nil)) answer-variable type temp-variable @@ -177,15 +177,15 @@ constructed. ;; which croak on the infinity character when it appears in a token, even ;; conditionalized out. #| - '((fixnum most-positive-fixnum most-negative-fixnum) - (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) - (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) - (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) + (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) + (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) |# ;; If we don't know, then we cannot provide "infinite" initial values for any of the ;; types but FIXNUM: - '((fixnum most-positive-fixnum most-negative-fixnum)) + '((fixnum most-positive-fixnum most-negative-fixnum)) ) @@ -205,42 +205,42 @@ constructed. (declare (si::c-local)) (pushnew (truly-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-"))) operation) (defmacro 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)))) (defmacro 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))))) @@ -291,18 +291,18 @@ code to be loaded. (defstruct (loop-universe - #+ecl (:type vector) - #-ecl (:print-function print-loop-universe) - #+nil (:copier nil) - #+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). - path-keywords ;hash table, value = (fn-name . extra-data). - type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. - type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. - ansi ;NIL, T, or :EXTENDED. - implicit-for-required ;see loop-hack-iteration + #+ecl (:type vector) + #-ecl (:print-function print-loop-universe) + #+nil (:copier nil) + #+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). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration ) @@ -310,10 +310,10 @@ code to be loaded. (defun print-loop-universe (u stream level) (declare (ignore level)) (let ((str (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))))) (format stream "#<~S ~A>" (type-of u) str))) @@ -323,13 +323,13 @@ code to be loaded. (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords - type-keywords type-symbols ansi) + type-keywords type-symbols ansi) (declare (si::c-local)) (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) @@ -339,17 +339,17 @@ 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 (defparameter *loop-destructuring-hooks* - nil + nil "If not NIL, this must be a list of two things: a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") @@ -358,10 +358,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (declare (si::c-local)) (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) @@ -369,76 +369,76 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (if (null var-val-pairs) nil (cons (if *loop-destructuring-hooks* - (cadr *loop-destructuring-hooks*) - 'loop-really-desetq) - var-val-pairs))) + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) (defparameter *loop-desetq-temporary* - (make-symbol "LOOP-DESETQ-TEMP")) + (make-symbol "LOOP-DESETQ-TEMP")) (defmacro loop-really-desetq (&environment env &rest var-val-pairs) (labels ((find-non-null (var) - ;; see if 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) - ;; if the value is declared 'unsafe', then the assignemnt - ;; is also unsafe. - (when (and (consp val) - (eq (first val) 'LOOP-UNSAFE)) - (let ((forms (rest val))) - (setf forms (if (rest forms) `(progn ,@forms) (first forms))) - (return-from loop-desetq-internal - `((LOOP-UNSAFE ,@(loop-desetq-internal var forms)))))) - ;; 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 (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 if 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) + ;; if the value is declared 'unsafe', then the assignemnt + ;; is also unsafe. + (when (and (consp val) + (eq (first val) 'LOOP-UNSAFE)) + (let ((forms (rest val))) + (setf forms (if (rest forms) `(progn ,@forms) (first forms))) + (return-from loop-desetq-internal + `((LOOP-UNSAFE ,@(loop-desetq-internal var forms)))))) + ;; 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 (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 @@ -550,7 +550,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;List of all the value-accumulation descriptor structures in the loop. ;;; See loop-get-collection-info. -(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) ;;;; Code Analysis Stuff @@ -563,28 +563,28 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." - form constant-value expected-type) - (setq constantp nil constant-value nil))) + (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + form constant-value expected-type) + (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) ;;;; LOOP Iteration Optimization (defparameter *loop-duplicate-code* - nil) + nil) (defparameter *loop-iteration-flag-variable* - (make-symbol "LOOP-NOT-FIRST-TIME")) + (make-symbol "LOOP-NOT-FIRST-TIME")) (defmacro loop-body (&environment env - prologue - before-loop - main-body - after-loop - epilogue) + prologue + before-loop + main-body + after-loop + epilogue) (declare (ignore env)) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) @@ -620,29 +620,29 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-error (format-string &rest format-args) (declare (si::c-local)) (si::simple-program-error "~?~%Current LOOP context:~{ ~S~}." - format-string format-args (loop-context))) + format-string format-args (loop-context))) (defun loop-warn (format-string &rest format-args) (declare (si::c-local)) (warn 'sys::simple-style-warning - :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-check-data-type (specified-type required-type - &optional (default-type required-type)) + &optional (default-type required-type)) (declare (si::c-local)) (if (null specified-type) default-type (multiple-value-bind (a b) (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 "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 "Specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) ;;;INTERFACE: Traditional, ANSI, Lucid. @@ -659,71 +659,71 @@ collected result will be returned as the value of the LOOP." ((null tree) (car (push (gensym) *ignores*))) ((atom tree) tree) (t (cons (subst-gensyms-for-nil (car tree)) - (subst-gensyms-for-nil (cdr tree)))))) + (subst-gensyms-for-nil (cdr tree)))))) (defun loop-build-destructuring-bindings (crocks forms) (if crocks (let ((*ignores* ())) - (declare (special *ignores*)) - `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) - ,(cadr crocks) - (declare (ignore ,@*ignores*)) - ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) + (declare (special *ignores*)) + `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) + ,(cadr crocks) + (declare (ignore ,@*ignores*)) + ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) forms)) (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) (declare (si::c-local)) (let ((*loop-original-source-code* *loop-source-code*) - (*loop-source-context* nil) - (*loop-iteration-variables* nil) - (*loop-variables* nil) - (*loop-nodeclare* nil) - (*loop-named-variables* 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-variable* nil) - (*loop-never-stepped-variable* nil) - (*loop-names* nil) - (*loop-collection-cruft* nil)) + (*loop-source-context* nil) + (*loop-iteration-variables* nil) + (*loop-variables* nil) + (*loop-nodeclare* nil) + (*loop-named-variables* 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-variable* nil) + (*loop-never-stepped-variable* 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 `(,(cond ((not vars) 'locally) - (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) - (t 'let)) - ,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 `(,(cond ((not vars) 'locally) + (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) + (t 'let)) + ,vars + ,@(loop-build-destructuring-bindings crocks forms))))))) (if *loop-names* - (do () ((null (car *loop-names*)) answer) - (setq answer `(block ,(pop *loop-names*) ,answer))) - `(block nil ,answer))))) + (do () ((null (car *loop-names*)) answer) + (setq answer `(block ,(pop *loop-names*) ,answer))) + `(block nil ,answer))))) (defun loop-iteration-driver () @@ -731,19 +731,19 @@ collected result will be returned as the value of the LOOP." (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)) - ;; Alternative is to ignore it, ie 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 "~S is an unknown keyword in LOOP macro." 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)) + ;; Alternative is to ignore it, ie 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 "~S is an unknown keyword in LOOP macro." keyword)))))))) @@ -799,8 +799,8 @@ collected result will be returned as the value of the LOOP." (push (loop-construct-return form) *loop-after-epilogue*)) (when *loop-final-value-culprit* (loop-warn "LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." - *loop-final-value-culprit*)) + however one was already established by a ~S clause." + *loop-final-value-culprit*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) @@ -825,67 +825,67 @@ collected result will be returned as the value of the LOOP." (defun loop-typed-init (data-type) (declare (si::c-local)) (cond ((null data-type) - nil) - ((subtypep data-type 'character) - #\0) - ((not (subtypep data-type 'number)) - nil) - ((subtypep data-type '(or float (complex float))) - (coerce 0 data-type)) - (t - 0))) + nil) + ((subtypep data-type 'character) + #\0) + ((not (subtypep data-type 'number)) + nil) + ((subtypep data-type '(or float (complex float))) + (coerce 0 data-type)) + (t + 0))) (defun loop-optional-type (&optional variable) (declare (si::c-local)) ;;No variable specified implies that no destructuring is permissible. - (and *loop-source-code* ;Don't get confused by NILs... + (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 - "Destructuring type pattern ~S contains unrecognized type keyword ~S." - z k)) - v)) - ((atom v) - (loop-error - "Destructuring type pattern ~S doesn't match 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 + "Destructuring type pattern ~S contains unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "Destructuring type pattern ~S doesn't match 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))))))) @@ -896,58 +896,58 @@ collected result will be returned as the value of the LOOP." (declare (si::c-local)) (when (or *loop-variables* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) - *loop-bind-stack*) + *loop-bind-stack*) (setq *loop-variables* nil - *loop-declarations* nil - *loop-desetq-crocks* nil - *loop-wrappers* nil))) + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) (defun loop-variable-p (name) (do ((entry *loop-bind-stack* (cdr entry))) (nil) (cond ((null entry) - (return nil)) - ((assoc name (caar entry) :test #'eq) - (return t))))) + (return nil)) + ((assoc name (caar entry) :test #'eq) + (return t))))) (defun loop-make-variable (name initialization dtype &optional iteration-variable-p) (declare (si::c-local)) (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (gensym "LOOP-IGNORE-")) - initialization) - *loop-variables*) - (push `(ignore ,name) *loop-declarations*)))) - ((atom name) - (cond (iteration-variable-p - (if (member name *loop-iteration-variables*) - (loop-error "Duplicated LOOP iteration variable ~S." name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) - (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) - (unless (symbolp name) - (loop-error "Bad variable ~S somewhere in LOOP." name)) - (loop-declare-variable name dtype) - ;; 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))) - *loop-variables*)) - (initialization - (cond (*loop-destructuring-hooks* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) - (loop-declare-variable name dtype) - (push (list newvar initialization) *loop-variables*) - ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)) - #+ignore - (loop-make-variable name nil dtype iteration-variable-p))))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar iteration-variable-p) - (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + (cond ((not (null initialization)) + (push (list (setq name (gensym "LOOP-IGNORE-")) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (iteration-variable-p + (if (member name *loop-iteration-variables*) + (loop-error "Duplicated LOOP iteration variable ~S." name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) + (unless (symbolp name) + (loop-error "Bad variable ~S somewhere in LOOP." name)) + (loop-declare-variable name dtype) + ;; 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))) + *loop-variables*)) + (initialization + (cond (*loop-destructuring-hooks* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)) + #+ignore + (loop-make-variable name nil dtype iteration-variable-p))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar iteration-variable-p) + (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) name) @@ -959,8 +959,8 @@ collected result will be returned as the value of the LOOP." (defun loop-declare-variable (name dtype) (declare (si::c-local)) (cond ((or (null name) (null dtype) (eq dtype t)) nil) - ((symbolp name) - (unless (or (eq dtype t) (member (truly-the symbol name) *loop-nodeclare*)) + ((symbolp name) + (unless (or (eq dtype t) (member (truly-the symbol name) *loop-nodeclare*)) ;; Allow redeclaration of a variable. This can be used by ;; the loop constructors to make the type more and more ;; precise as we add keywords @@ -973,13 +973,13 @@ collected result will be returned as the value of the LOOP." (if previous (setf (second previous) dtype) (push `(type ,dtype ,name) *loop-declarations*))))) - ((consp name) - (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype)) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype) - (loop-declare-variable (cdr name) dtype)))) - (t (error "Invalid LOOP variable passed in: ~S." name)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (error "Invalid LOOP variable passed in: ~S." name)))) (defun loop-maybe-bind-form (form data-type) @@ -992,46 +992,46 @@ collected result will be returned as the value of the LOOP." (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-variable))) - (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-variable))) + (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 () @@ -1053,7 +1053,7 @@ collected result will be returned as the value of the LOOP." (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 nil)))) (defun loop-do-return () @@ -1064,24 +1064,24 @@ collected result will be returned as the value of the LOOP." (defstruct (loop-collector - #+ecl (:type vector) - #+nil (:copier nil) - #+nil (:predicate nil)) + #+ecl (:type vector) + #+nil (:copier nil) + #+nil (:predicate nil)) name class (history nil) (tempvars nil) dtype - (data nil)) ;collector-specific data + (data nil)) ;collector-specific data (defun loop-get-collection-info (collector class default-type) (declare (si::c-local)) (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 "Value accumulation recipient name, ~S, is not a symbol." name)) (unless name @@ -1089,47 +1089,47 @@ collected result will be returned as the value of the LOOP." (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (truly-the symbol name) *loop-collection-cruft* - :key #'loop-collector-name))) + :key #'loop-collector-name))) (cond ((not cruft) - (when (and name (loop-variable-p name)) - (loop-error "Variable ~S cannot be used in INTO clause" 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~@ - 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)))) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S cannot be used in INTO clause" 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~@ + 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)))) (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))))) @@ -1137,21 +1137,21 @@ collected result will be returned as the value of the LOOP." -(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT +(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT (multiple-value-bind (lc form) (loop-get-collection-info specifically 'sum default-type) (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-variable - (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-variable + (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) + (if (eq specifically 'count) `(when ,form (setq ,(car tempvars) (1+ ,(car tempvars)))) @@ -1167,12 +1167,12 @@ collected result will be returned as the value of the LOOP." (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)) @@ -1188,7 +1188,7 @@ collected result will be returned as the value of the LOOP." (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))) @@ -1200,7 +1200,7 @@ collected result will be returned as the value of the LOOP." (loop-disallow-anonymous-collectors) (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-variable*)))) + ,(loop-construct-return *loop-when-it-variable*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) @@ -1212,17 +1212,17 @@ collected result will be returned as the value of the LOOP." (loop-disallow-conditional :with) (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-variable-p var)) (loop-error "Variable ~S has already been used" var)) (loop-make-variable 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 @@ -1230,22 +1230,22 @@ collected result will be returned as the value of the LOOP." (defun loop-hack-iteration (entry) (declare (si::c-local)) (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 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)))) @@ -1255,7 +1255,7 @@ collected result will be returned as the value of the LOOP." (setq pseudo-steps (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. This error is typicall caused + (loop-error "Iteration in LOOP follows body code. This error is typicall caused by a WHILE, UNTIL or similar condition placed in between FOR, AS, and similar iterations. Note that this is not a valid ANSI code.")) (unless tem (setq tem data)) @@ -1264,26 +1264,26 @@ Note that this is not a valid ANSI code.")) (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps (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*) - *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*) + *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*)))) - ;;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*)))) + ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. + (loop-pop-source) + (setq entry tem))))) ;;;; Main Iteration Drivers @@ -1292,15 +1292,15 @@ Note that this is not a valid ANSI code.")) ;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)) (apply (car tem) var first-arg data-type (cdr tem)))) @@ -1325,7 +1325,7 @@ Note that this is not a valid ANSI code.")) (declare (si::c-local)) (or *loop-when-it-variable* (setq *loop-when-it-variable* - (loop-make-variable (gensym "LOOP-IT-") nil nil)))) + (loop-make-variable (gensym "LOOP-IT-") nil nil)))) ;;;; Various FOR/AS Subdispatches @@ -1339,43 +1339,43 @@ Note that this is not a valid ANSI code.")) (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable 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-iteration-variable 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-variable - 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-variable index-var 0 'fixnum) (let* ((length 0) - (length-form (cond ((not constantp) - (let ((v (gensym "LOOP-ACROSS-LIST"))) - (push `(setq ,v (length ,vector-var)) *loop-prologue*) - (loop-make-variable 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-LIST"))) + (push `(setq ,v (length ,vector-var)) *loop-prologue*) + (loop-make-variable 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))))))) @@ -1390,17 +1390,17 @@ Note that this is not a valid ANSI code.")) ;;While a Discerning Compiler may deal intelligently with (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 cons-cdr))))) + (loop-pop-source) + (loop-get-form)) + (t '(function cons-cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) - (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") - (values `(funcall ,stepper ,listvar) nil)) - ((and (consp stepper) (eq (car stepper) 'function)) - (values (list (cadr stepper) listvar) (cadr stepper))) - (t (values `(funcall ,(loop-make-variable (gensym "LOOP-FN") stepper 'function) - ,listvar) - nil))))) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + (values `(funcall ,stepper ,listvar) nil)) + ((and (consp stepper) (eq (car stepper) 'function)) + (values (list (cadr stepper) listvar) (cadr stepper))) + (t (values `(funcall ,(loop-make-variable (gensym "LOOP-FN") stepper 'function) + ,listvar) + nil))))) (defun loop-for-on (var val data-type) @@ -1408,29 +1408,29 @@ Note that this is not a valid ANSI code.")) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) - (loop-make-iteration-variable var list data-type)) - (t - (loop-make-variable (setq listvar (gensym)) list 'list) - (loop-make-iteration-variable var nil data-type))) + (loop-make-iteration-variable var list data-type)) + (t + (loop-make-variable (setq listvar (gensym)) list 'list) + (loop-make-iteration-variable 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) + (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))))))))))) + `(() (,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) @@ -1440,24 +1440,24 @@ Note that this is not a valid ANSI code.")) (loop-make-iteration-variable var nil data-type) (loop-make-variable listvar list 'list) (let ((list-step (loop-list-step listvar))) - (let* ((first-endtest `(endp ,listvar)) - (other-endtest first-endtest) - (step `(,var (cons-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 (cons-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 - #+ecl (:type vector) - #+nil (:copier nil) - #+nil (:predicate nil)) + #+ecl (:type vector) + #+nil (:copier nil) + #+nil (:predicate nil)) names preposition-groups inclusive-permitted @@ -1470,12 +1470,12 @@ Note that this is not a valid ANSI code.")) (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)) @@ -1486,46 +1486,46 @@ Note that this is not a valid ANSI code.")) ;; 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 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 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 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 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-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) ;; 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-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) @@ -1538,144 +1538,144 @@ Note that this is not a valid ANSI code.")) (let ((tem (loop-tassoc name *loop-named-variables*))) (declare (list tem)) (cond ((null tem) (values (gensym) nil)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) - (values (cdr tem) t))))) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) (declare (si::c-local)) (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 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-variables*)) - (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-variables*))) - (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) - (return nil)))) - (t (return (nreverse prepositional-phrases))))))) + (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 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-variables*)) + (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-variables*))) + (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 indexv-user-specified-p - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) (declare (si::c-local) - (ignore indexv-user-specified-p)) - (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) - ) + (ignore indexv-user-specified-p)) + (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) + ) (when variable (loop-make-iteration-variable 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-variable 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)) - (loop-make-iteration-variable 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 indexv-type)) - (setq endform (if limit-constantp - `',limit-value - (loop-make-variable - (gensym "LOOP-LIMIT") form indexv-type)))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY")) form indexv-type))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path.~@ - Invalid prepositions specified in iteration path descriptor or something?" - prep))) + ((:of :in) + (setq sequencep t) + (loop-make-variable 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)) + (loop-make-iteration-variable 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 indexv-type)) + (setq endform (if limit-constantp + `',limit-value + (loop-make-variable + (gensym "LOOP-LIMIT") form indexv-type)))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form indexv-type)) + (unless stepby-constantp + (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY")) form indexv-type))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path.~@ + Invalid prepositions specified in iteration path descriptor or something?" + prep))) (when (and odir dir (not (eq dir odir))) - (loop-error "Conflicting stepping directions in LOOP sequencing path")) + (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")) ;; Now fill in the defaults. (unless start-given (loop-make-iteration-variable - indexv - (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) - indexv-type)) + indexv + (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) + indexv-type)) (cond ((member dir '(nil :up)) - (when (or limit-given default-top) - (unless limit-given - (loop-make-variable (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-variable (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))))) (setq step `(loop-unsafe ,step)) (when testfn (setq test `(,testfn ,indexv ,endform))) @@ -1697,10 +1697,10 @@ Note that this is not a valid ANSI code.")) (t indexv-type)))) (unless (subtypep indexv-type new-type) (loop-declare-variable indexv new-type))) - (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) - (setq remaining-tests t))) + (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)))) + () () ,first-test ,step-hack)))) ;;;; Interfaces to the Master Sequencer @@ -1731,85 +1731,85 @@ Note that this is not a valid ANSI code.")) (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) (check-type which (member hash-key hash-value)) (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 (if (eq which 'hash-key) 'hash-value 'hash-key)) + (loop-named-var (if (eq which 'hash-key) '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-variable)) + dummy-predicate-var (loop-when-it-variable)) (let* ((key-var nil) - (val-var nil) - (temp-val-var (gensym "LOOP-HASH-VAL-TEMP-")) - (temp-key-var (gensym "LOOP-HASH-KEY-TEMP-")) - (temp-predicate-var (gensym "LOOP-HASH-PREDICATE-VAR-")) - (variable (or variable (gensym))) - (bindings `((,variable nil ,data-type) - (,ht-var ,(cadar prep-phrases)) - ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) - (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) - (when (consp key-var) - (setq post-steps `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-")) - ,@post-steps)) - (push `(,key-var nil) bindings)) - (when (consp val-var) - (setq post-steps `(,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-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) - (,next-fn) - ;; We use M-V-BIND instead of M-V-SETQ because we only - ;; want to assign values to the key and val vars when we - ;; are in the hash table. When we reach the end, - ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and - ;; temp-val-var. This might break any type declarations - ;; on the key and val vars. - (when ,temp-predicate-var - (setq ,val-var ,temp-val-var) - (setq ,key-var ,temp-key-var)) - (setq ,dummy-predicate-var ,temp-predicate-var) - )) ;post-test - ,post-steps))))) + (val-var nil) + (temp-val-var (gensym "LOOP-HASH-VAL-TEMP-")) + (temp-key-var (gensym "LOOP-HASH-KEY-TEMP-")) + (temp-predicate-var (gensym "LOOP-HASH-PREDICATE-VAR-")) + (variable (or variable (gensym))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (if (eq which 'hash-key) + (setq key-var variable val-var (and other-p other-var)) + (setq key-var (and other-p other-var) val-var variable)) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (consp key-var) + (setq post-steps `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-")) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (consp val-var) + (setq post-steps `(,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-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) + (,next-fn) + ;; We use M-V-BIND instead of M-V-SETQ because we only + ;; want to assign values to the key and val vars when we + ;; are in the hash table. When we reach the end, + ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and + ;; temp-val-var. This might break any type declarations + ;; on the key and val vars. + (when ,temp-predicate-var + (setq ,val-var ,temp-val-var) + (setq ,key-var ,temp-key-var)) + (setq ,dummy-predicate-var ,temp-predicate-var) + )) ;post-test + ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) (cond ((and prep-phrases (cdr prep-phrases)) - (loop-error "Too many prepositions!")) - ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Unknow preposition ~S" (caar prep-phrases)))) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknow 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))) - (pkg (or (cadar prep-phrases) '*package*))) + (next-fn (gensym "LOOP-PKGSYM-NEXT-")) + (variable (or variable (gensym))) + (pkg (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,pkg)) () () () (not (multiple-value-setq (,(progn - ;;@@@@ If an implementation can get away without actually - ;; using a variable here, so much the better. - (loop-when-it-variable)) - ,variable) - (,next-fn))) + ;;@@@@ If an implementation can get away without actually + ;; using a variable here, so much the better. + (loop-when-it-variable)) + ,variable) + (,next-fn))) ()))) ;;;; ANSI Loop @@ -1817,88 +1817,88 @@ Note that this is not a valid ANSI code.")) (defun make-ansi-loop-universe (extended-p) (declare (si::c-local)) (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 the test on always. - (thereis (loop-do-thereis t)) - (while (loop-do-while nil :while)) ; Normal, do while - (until (loop-do-while t :until)) ; Negate the 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 the 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)) - (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)))) + :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 the test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ; Negate the 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 the 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)) + (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)))) (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))) + :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))) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external))) w)) (defparameter *loop-ansi-universe* - (make-ansi-loop-universe nil)) + (make-ansi-loop-universe nil)) (defun loop-standard-expansion (keywords-and-forms environment universe) @@ -1906,7 +1906,7 @@ Note that this is not a valid ANSI code.")) (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)))))) ;;;INTERFACE: ANSI diff --git a/src/lsp/mislib.lsp b/src/lsp/mislib.lsp index 9b37225ae..1cd4c19f5 100644 --- a/src/lsp/mislib.lsp +++ b/src/lsp/mislib.lsp @@ -41,37 +41,37 @@ successfully, T is returned, else error." (defun do-time (closure) #-boehm-gc (let* ((real-start (get-internal-real-time)) - (run-start (get-internal-run-time)) - gc-start - bytes-consed - real-end - run-end - gc-end) + (run-start (get-internal-run-time)) + gc-start + bytes-consed + real-end + run-end + gc-end) ;; Garbage collection forces counters to be updated (si::gc t) (setf gc-start (si::gc-time)) (multiple-value-prog1 - (funcall closure) + (funcall closure) (setq run-end (get-internal-run-time) - real-end (get-internal-real-time) - gc-end (si::gc-time)) + real-end (get-internal-real-time) + gc-end (si::gc-time)) (format *trace-output* "real time : ~,3F secs~%~ run time : ~,3F secs~%~ GC time : ~,3F secs~%" - (/ (- real-end real-start) internal-time-units-per-second) - (/ (- run-end run-start) internal-time-units-per-second) - (/ (- gc-end gc-start) internal-time-units-per-second)))) + (/ (- real-end real-start) internal-time-units-per-second) + (/ (- run-end run-start) internal-time-units-per-second) + (/ (- gc-end gc-start) internal-time-units-per-second)))) #+boehm-gc (let* ((*do-time-level* (1+ *do-time-level*)) real-start - run-start - consed-start - gc-no-start - real-end - run-end - consed-end - gc-no-end) + run-start + consed-start + gc-no-start + real-end + run-end + consed-end + gc-no-end) ;; Garbage collection forces the value of counters to be updated (si::gc t) ;; If there are no nested calls, we just reset the counters @@ -79,11 +79,11 @@ successfully, T is returned, else error." ;; but in general we copy the previous values. (multiple-value-setq (consed-start gc-no-start) (gc-stats t)) (setq real-start (get-internal-real-time) - run-start (get-internal-run-time)) + run-start (get-internal-run-time)) (multiple-value-prog1 - (funcall closure) + (funcall closure) (setq run-end (get-internal-run-time) - real-end (get-internal-real-time)) + real-end (get-internal-real-time)) ;; Garbage collection forces the value of counters to be updated (si::gc t) (multiple-value-setq (consed-end gc-no-end) (gc-stats nil)) @@ -93,10 +93,10 @@ successfully, T is returned, else error." run time : ~,3F secs~%~ gc count : ~D times~%~ consed : ~D bytes~%" - (/ (- real-end real-start) internal-time-units-per-second) - (/ (- run-end run-start) internal-time-units-per-second) - (- gc-no-end gc-no-start) - (- consed-end consed-start))))) + (/ (- real-end real-start) internal-time-units-per-second) + (/ (- run-end run-start) internal-time-units-per-second) + (- gc-no-end gc-no-start) + (- consed-end consed-start))))) (defmacro time (form) "Syntax: (time form) @@ -149,14 +149,14 @@ Evaluates FORM, outputs the realtime and runtime used for the evaluation to #endif @(return) = ecl_make_ratio(ecl_make_fixnum(mw),ecl_make_fixnum(60)); }" - :one-liner nil)) + :one-liner nil)) (defun recode-universal-time (sec min hour day month year tz dst) (declare (si::c-local)) (let ((days (+ (if (and (leap-year-p year) (> month 2)) 1 0) - (1- day) - (svref month-startdays (1- month)) - (number-of-days-from-1900 year)))) + (1- day) + (svref month-startdays (1- month)) + (number-of-days-from-1900 year)))) (+ sec (* 60 (+ min (* 60 (+ tz dst hour (* 24 days)))))))) (defun decode-universal-time (orig-ut &optional (tz nil tz-p) &aux (dstp nil)) @@ -180,13 +180,13 @@ DECODED-TIME." (incf year)) (when (leap-year-p year) (cond ((= day 60) (setf month 2 day 29)) - ((> day 60) (decf day)))) + ((> day 60) (decf day)))) (unless month (setq month (position day month-startdays :test #'<=) - day (- day (svref month-startdays (1- month))))) + day (- day (svref month-startdays (1- month))))) (if (and (not tz-p) (daylight-saving-time-p orig-ut year)) - (setf tz-p t dstp t) - (return (values sec min hour day month year dow dstp tz)))))) + (setf tz-p t dstp t) + (return (values sec min hour day month year dow dstp tz)))))) (defun encode-universal-time (sec min hour day month year &optional tz) "Args: (second minute hour date month year @@ -196,19 +196,19 @@ GET-DECODED-TIME." (when (<= 0 year 99) ;; adjust to year in the century within 50 years of this year (multiple-value-bind (sec min hour day month this-year dow dstp tz) - (get-decoded-time) + (get-decoded-time) (declare (ignore sec min hour day month dow dstp tz)) (incf year (* 100 (ceiling (- this-year year 50) 100))))) (let ((dst 0)) (unless tz (setq tz (rational (get-local-time-zone))) (when (daylight-saving-time-p (recode-universal-time sec min hour day month year tz -1) year) - ;; assume DST applies, and check if at corresponging UT it applies. - ;; There is an ambiguity between midnight and 1 o'clock on the day - ;; when time reverts from DST to solar: - ;; 12:01 on that day could be either 11:01 UT (before the switch) or - ;; 12:01 UT (after the switch). We opt for the former. - (setf dst -1))) + ;; assume DST applies, and check if at corresponging UT it applies. + ;; There is an ambiguity between midnight and 1 o'clock on the day + ;; when time reverts from DST to solar: + ;; 12:01 on that day could be either 11:01 UT (before the switch) or + ;; 12:01 UT (after the switch). We opt for the former. + (setf dst -1))) (recode-universal-time sec min hour day month year tz dst))) (defun daylight-saving-time-p (universal-time year) @@ -220,82 +220,82 @@ Universal Time UT, which defaults to the current time." ;; therefore restrict the time to the interval that can handled by ;; the timezone database. (let* ((utc-1-1-1970 2208988800) - (unix-time (- universal-time utc-1-1-1970))) + (unix-time (- universal-time utc-1-1-1970))) (cond ((minusp unix-time) - ;; For dates before 1970 we shift to 1980/81 to guess the daylight - ;; saving times. - (setf unix-time - (+ (if (leap-year-p year) - #.(encode-universal-time 0 0 0 1 1 1980 0) - #.(encode-universal-time 0 0 0 1 1 1981 0)) - (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970)))) - ((not (fixnump unix-time)) - ;; Same if date is too big: we shift to year 2035/36, like SBCL does. - (setf unix-time - (+ (if (leap-year-p year) - #.(encode-universal-time 0 0 0 1 1 2032 0) - #.(encode-universal-time 0 0 0 1 1 2033 0)) - (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970))))) + ;; For dates before 1970 we shift to 1980/81 to guess the daylight + ;; saving times. + (setf unix-time + (+ (if (leap-year-p year) + #.(encode-universal-time 0 0 0 1 1 1980 0) + #.(encode-universal-time 0 0 0 1 1 1981 0)) + (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970)))) + ((not (fixnump unix-time)) + ;; Same if date is too big: we shift to year 2035/36, like SBCL does. + (setf unix-time + (+ (if (leap-year-p year) + #.(encode-universal-time 0 0 0 1 1 2032 0) + #.(encode-universal-time 0 0 0 1 1 2033 0)) + (- universal-time (encode-universal-time 0 0 0 1 1 year 0) utc-1-1-1970))))) #-ecl-min (ffi::c-inline (unix-time) (:unsigned-long) :bool " { - time_t when = (#0); - struct tm *ltm = localtime(&when); - @(return) = ltm->tm_isdst; + time_t when = (#0); + struct tm *ltm = localtime(&when); + @(return) = ltm->tm_isdst; }" - :one-liner nil))) + :one-liner nil))) (defun get-decoded-time () "Args: () Returns the current day-and-time as nine values: - second (0 - 59) - minute (0 - 59) - hour (0 - 23) - date (1 - 31) - month (1 - 12) - year (Christian, not Japanese long-live-Emperor) - day of week (0 for Mon, .. 6 for Sun) - summer time or not (T or NIL) - time zone (-9 in Japan) + second (0 - 59) + minute (0 - 59) + hour (0 - 23) + date (1 - 31) + month (1 - 12) + year (Christian, not Japanese long-live-Emperor) + day of week (0 for Mon, .. 6 for Sun) + summer time or not (T or NIL) + time zone (-9 in Japan) Sunday is the *last* day of the week!!" (decode-universal-time (get-universal-time))) (defun ensure-directories-exist (pathname &key verbose (mode #o777)) "Args: (ensure-directories pathname &key :verbose) Creates tree of directories specified by the given pathname. Outputs - (VALUES pathname created) + (VALUES pathname created) where CREATED is true only if we succeeded on creating all directories." (let* ((created nil) - (full-pathname (merge-pathnames pathname)) - d) + (full-pathname (merge-pathnames pathname)) + d) (when (typep full-pathname 'logical-pathname) (setf full-pathname (translate-logical-pathname full-pathname))) (when (or (wild-pathname-p full-pathname :directory) - (wild-pathname-p full-pathname :host) - (wild-pathname-p full-pathname :device)) + (wild-pathname-p full-pathname :host) + (wild-pathname-p full-pathname :device)) (error 'file-error :pathname pathname)) ;; Here we have already a full pathname. We set our own ;; *default-pathname-defaults* to avoid that the user's value, ;; which may contain names or types, clobbers our computations. (let ((*default-pathname-defaults* - (make-pathname :name nil :type nil :directory nil - :defaults full-pathname))) + (make-pathname :name nil :type nil :directory nil + :defaults full-pathname))) (dolist (item (pathname-directory full-pathname)) - (setf d (nconc d (list item))) - (let* ((p (make-pathname :directory d :defaults *default-pathname-defaults*))) - (unless (or (symbolp item) (si::file-kind p nil)) - (setf created t) - (let ((ps (namestring p))) - (when verbose - (format t "~%;;; Making directory ~A" ps)) - (si::mkdir ps mode))))) + (setf d (nconc d (list item))) + (let* ((p (make-pathname :directory d :defaults *default-pathname-defaults*))) + (unless (or (symbolp item) (si::file-kind p nil)) + (setf created t) + (let ((ps (namestring p))) + (when verbose + (format t "~%;;; Making directory ~A" ps)) + (si::mkdir ps mode))))) (values pathname created)))) (defmacro with-hash-table-iterator ((iterator package) &body body) "Syntax: (with-hash-table-iterator (iterator package) &body body) Loop over the elements of a hash table. ITERATOR is a lexically bound function that outputs three values - (VALUES entry-p key value) + (VALUES entry-p key value) ENTRY-P is true only if KEY and VALUE denote a pair of key and value of the hash table; otherwise it signals that we have reached the end of the hash table." `(let ((,iterator (hash-table-iterator ,package))) diff --git a/src/lsp/module.lsp b/src/lsp/module.lsp index 45e45e6f5..a159a3b25 100644 --- a/src/lsp/module.lsp +++ b/src/lsp/module.lsp @@ -10,7 +10,7 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; module routines +;;;; module routines ;; This is taken from SBCL's code/module.lisp which is in the public ;; domain. @@ -52,27 +52,27 @@ module." (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)))) (pushnew #'(lambda (module) - (let* ((module (string module))) - (or - (let ((path (make-pathname :name module :defaults "SYS:"))) - (load path :if-does-not-exist nil)) - (let ((path (make-pathname :name (string-downcase module) + (let* ((module (string module))) + (or + (let ((path (make-pathname :name module :defaults "SYS:"))) + (load path :if-does-not-exist nil)) + (let ((path (make-pathname :name (string-downcase module) :defaults "SYS:"))) - (load path :if-does-not-exist nil))))) - *module-provider-functions*) + (load path :if-does-not-exist nil))))) + *module-provider-functions*) diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index 66dff01c9..ab870d55d 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -119,17 +119,17 @@ by ALLOW-WITH-INTERRUPTS." (ext:with-unique-names (lock owner count process) `(let* ((,lock ,lock-form) (,owner (mp:lock-owner ,lock)) - (,count (mp:lock-count ,lock))) + (,count (mp:lock-count ,lock))) (declare (type fixnum ,count)) (without-interrupts (unwind-protect (with-restored-interrupts (mp::get-lock ,lock) (locally ,@body)) - (let ((,process mp:*current-process*)) - (declare (optimize (speed 3) (safety 0) (debug 0))) - (when (and (eq ,process (mp:lock-owner ,lock)) - (or (not (eq ,owner ,process)) - (> (the fixnum (mp:lock-count ,lock)) - (the fixnum ,count)))) - (mp::giveup-lock ,lock)))))))) + (let ((,process mp:*current-process*)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (when (and (eq ,process (mp:lock-owner ,lock)) + (or (not (eq ,owner ,process)) + (> (the fixnum (mp:lock-count ,lock)) + (the fixnum ,count)))) + (mp::giveup-lock ,lock)))))))) diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index a55a3c8e5..a9e798e60 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -20,55 +20,55 @@ #. (flet ((binary-search (f min max) - (do ((new (/ (+ min max) 2) (/ (+ min max) 2))) - ((>= min max) - max) - (if (funcall f new) - (if (= new max) - (return max) - (setq max new)) - (if (= new min) - (return max) - (setq min new))))) + (do ((new (/ (+ min max) 2) (/ (+ min max) 2))) + ((>= min max) + max) + (if (funcall f new) + (if (= new max) + (return max) + (setq max new)) + (if (= new min) + (return max) + (setq min new))))) (epsilon+ (x) - (/= (float 1 x) (+ (float 1 x) x))) + (/= (float 1 x) (+ (float 1 x) x))) (epsilon- (x) - (/= (float 1 x) (- (float 1 x) x)))) + (/= (float 1 x) (- (float 1 x) x)))) #+ecl-min (si::trap-fpe 'last nil) `(eval-when (compile load eval) (defconstant short-float-epsilon ,(binary-search #'epsilon+ (coerce 0 'short-float) (coerce 1 'short-float)) "The smallest postive short-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") + (not (= (float 1 E) (+ (float 1 E) E)))") (defconstant single-float-epsilon ,(binary-search #'epsilon+ (coerce 0 'single-float) (coerce 1 'single-float)) "The smallest postive single-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") + (not (= (float 1 E) (+ (float 1 E) E)))") (defconstant double-float-epsilon ,(binary-search #'epsilon+ (coerce 0 'double-float) (coerce 1 'double-float)) "The smallest postive double-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") + (not (= (float 1 E) (+ (float 1 E) E)))") (defconstant long-float-epsilon ,(binary-search #'epsilon+ (coerce 0 'long-float) (coerce 1 'long-float)) "The smallest postive long-float E that satisfies - (not (= (float 1 E) (+ (float 1 E) E)))") + (not (= (float 1 E) (+ (float 1 E) E)))") (defconstant short-float-negative-epsilon ,(binary-search #'epsilon- (coerce 0 'short-float) (coerce 1 'short-float)) "The smallest positive short-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") + (not (= (float 1 E) (- (float 1 E) E)))") (defconstant single-float-negative-epsilon ,(binary-search #'epsilon- (coerce 0 'single-float) (coerce 1 'single-float)) "The smallest positive single-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") + (not (= (float 1 E) (- (float 1 E) E)))") (defconstant double-float-negative-epsilon ,(binary-search #'epsilon- (coerce 0 'double-float) (coerce 1 'double-float)) "The smallest positive double-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") + (not (= (float 1 E) (- (float 1 E) E)))") (defconstant long-float-negative-epsilon ,(binary-search #'epsilon- (coerce 0 'long-float) (coerce 1 'long-float)) "The smallest positive long-float E that satisfies - (not (= (float 1 E) (- (float 1 E) E)))") + (not (= (float 1 E) (- (float 1 E) E)))") )) #+IEEE-FLOATING-POINT @@ -132,12 +132,12 @@ RADIANS) and (SIN RADIANS) respectively." (defmacro c-num-op (name arg) #+long-float `(ffi::c-inline (,arg) (:long-double) :long-double - ,(format nil "~al(#0)" name) - :one-liner t) + ,(format nil "~al(#0)" name) + :one-liner t) #-long-float `(ffi::c-inline (,arg) (:double) :double - ,(format nil "~a(#0)" name) - :one-liner t))) + ,(format nil "~a(#0)" name) + :one-liner t))) (defun asin (x) "Args: (number) @@ -146,21 +146,21 @@ Returns the arc sine of NUMBER." (complex-asin x) #-ecl-min (let* ((x (float x)) - (xr (float x 1l0))) - (declare (long-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (c-num-op "asin" xr) x) - (complex-asin x))))) + (xr (float x 1l0))) + (declare (long-float xr)) + (if (and (<= -1.0 xr) (<= xr 1.0)) + (float (c-num-op "asin" xr) x) + (complex-asin x))))) ;; Ported from CMUCL (defun complex-asin (z) (declare (number z) - (si::c-local)) + (si::c-local)) (let ((sqrt-1-z (sqrt (- 1 z))) - (sqrt-1+z (sqrt (+ 1 z)))) + (sqrt-1+z (sqrt (+ 1 z)))) (complex (atan (realpart z) (realpart (* sqrt-1-z sqrt-1+z))) - (asinh (imagpart (* (conjugate sqrt-1-z) - sqrt-1+z)))))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z)))))) (defun acos (x) "Args: (number) @@ -169,21 +169,21 @@ Returns the arc cosine of NUMBER." (complex-acos x) #-ecl-min (let* ((x (float x)) - (xr (float x 1l0))) - (declare (long-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (c-num-op "acos" xr) (float x)) - (complex-acos x))))) + (xr (float x 1l0))) + (declare (long-float xr)) + (if (and (<= -1.0 xr) (<= xr 1.0)) + (float (c-num-op "acos" xr) (float x)) + (complex-acos x))))) ;; Ported from CMUCL (defun complex-acos (z) (declare (number z) - (si::c-local)) + (si::c-local)) (let ((sqrt-1+z (sqrt (+ 1 z))) - (sqrt-1-z (sqrt (- 1 z)))) + (sqrt-1-z (sqrt (- 1 z)))) (complex (* 2 (atan (realpart sqrt-1-z) (realpart sqrt-1+z))) - (asinh (imagpart (* (conjugate sqrt-1+z) - sqrt-1-z)))))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z)))))) #+(and (not ecl-min) win32 (not mingw32)) (progn @@ -204,9 +204,9 @@ Returns the hyperbolic arc sine of NUMBER." ;(log (+ x (sqrt (+ 1.0 (* x x))))) (if #+(or ecl-min) t #-(or ecl-min) (complexp x) (let* ((iz (complex (- (imagpart x)) (realpart x))) - (result (complex-asin iz))) - (complex (imagpart result) - (- (realpart result)))) + (result (complex-asin iz))) + (complex (imagpart result) + (- (realpart result)))) #-(or ecl-min) (float (c-num-op "asinh" x) (float x)))) @@ -219,19 +219,19 @@ Returns the hyperbolic arc cosine of NUMBER." (complex-acosh x) #-(or ecl-min) (let* ((x (float x)) - (xr (float x 1d0))) - (declare (double-float xr)) - (if (<= 1.0 xr) - (float (c-num-op "acosh" xr) (float x)) - (complex-acosh x))))) + (xr (float x 1d0))) + (declare (double-float xr)) + (if (<= 1.0 xr) + (float (c-num-op "acosh" xr) (float x)) + (complex-acosh x))))) (defun complex-acosh (z) (declare (number z) (si::c-local)) (let ((sqrt-z-1 (sqrt (- z 1))) - (sqrt-z+1 (sqrt (+ z 1)))) + (sqrt-z+1 (sqrt (+ z 1)))) (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)))))) (defun atanh (x) "Args: (number) @@ -241,11 +241,11 @@ Returns the hyperbolic arc tangent of NUMBER." (complex-atanh x) #-(or ecl-min) (let* ((x (float x)) - (xr (float x 1d0))) - (declare (double-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (c-num-op "atanh" xr) (float x)) - (complex-atanh x))))) + (xr (float x 1d0))) + (declare (double-float xr)) + (if (and (<= -1.0 xr) (<= xr 1.0)) + (float (c-num-op "atanh" xr) (float x)) + (complex-atanh x))))) (defun complex-atanh (z) (declare (number z) (si::c-local)) @@ -303,7 +303,7 @@ Returns the position part (in ECL, the cdr part) of the byte specifier BYTE." Extracts a byte from INTEGER at the specified byte position, right-justifies the byte, and returns the result as an integer." (logand (ash integer (- (byte-position bytespec))) - (lognot (ash -1 (byte-size bytespec))))) + (lognot (ash -1 (byte-size bytespec))))) (defun ldb-test (bytespec integer) "Args: (bytespec integer) @@ -314,25 +314,25 @@ Returns T if at least one bit of the specified byte is 1; NIL otherwise." "Args: (bytespec integer) Extracts the specified byte from INTEGER and returns the result as an integer." (logand (ash (lognot (ash -1 (byte-size bytespec))) - (byte-position bytespec)) - integer)) + (byte-position bytespec)) + integer)) (defun dpb (newbyte bytespec integer) "Args: (newbyte bytespec integer) Replaces the specified byte of INTEGER with NEWBYTE (an integer) and returns the result." (let* ((pos (byte-position bytespec)) - (size (byte-size bytespec)) - (mask (ash (lognot (ash -1 size)) pos))) + (size (byte-size bytespec)) + (mask (ash (lognot (ash -1 size)) pos))) (logior (logandc2 integer mask) - (logand (ash newbyte pos) mask)))) + (logand (ash newbyte pos) mask)))) (defun deposit-field (newbyte bytespec integer) "Args: (integer1 bytespec integer2) Returns an integer represented by the bit sequence obtained by replacing the specified bits of INTEGER2 with the specified bits of INTEGER1." (let* ((pos (byte-position bytespec)) - (size (byte-size bytespec)) - (mask (ash (lognot (ash -1 size)) pos))) + (size (byte-size bytespec)) + (mask (ash (lognot (ash -1 size)) pos))) (logior (logandc2 integer mask) - (logand newbyte mask)))) \ No newline at end of file + (logand newbyte mask)))) diff --git a/src/lsp/packlib.lsp b/src/lsp/packlib.lsp index 2102c0f84..e2a8dc74d 100644 --- a/src/lsp/packlib.lsp +++ b/src/lsp/packlib.lsp @@ -22,12 +22,12 @@ STRING-DESIGNATOR may be a symbol, in which case the print name of the symbol is used." (let ((symbol-name (string string-or-symbol))) (mapcan #'(lambda (p) - (multiple-value-bind (s i) - (find-symbol symbol-name p) - (if (or (eq i :internal) (eq i :external)) - (list s) - nil))) - (list-all-packages)))) + (multiple-value-bind (s i) + (find-symbol symbol-name p) + (if (or (eq i :internal) (eq i :external)) + (list s) + nil))) + (list-all-packages)))) (defun packages-iterator (packages options maybe-list) (let ((all-symbols nil)) @@ -35,58 +35,58 @@ is used." (setq packages (list packages))) (dolist (p packages) (let ((package (si::coerce-to-package p))) - (multiple-value-bind (hash-ext hash-int packages-used) - (si::package-hash-tables package) - (when (member :external options) - (push (list package :external hash-ext) all-symbols)) - (when (member :internal options) - (push (list package :internal hash-int) all-symbols)) - (when (member :inherited options) - (dolist (p packages-used) - (push (list package :inherited (si::package-hash-tables p)) - all-symbols)))))) + (multiple-value-bind (hash-ext hash-int packages-used) + (si::package-hash-tables package) + (when (member :external options) + (push (list package :external hash-ext) all-symbols)) + (when (member :internal options) + (push (list package :internal hash-int) all-symbols)) + (when (member :inherited options) + (dolist (p packages-used) + (push (list package :inherited (si::package-hash-tables p)) + all-symbols)))))) (unless all-symbols (return-from packages-iterator #'(lambda () (values nil nil nil nil)))) (let* ((current (pop all-symbols)) - (package (first current)) - (type (second current)) - (iterator (si::hash-table-iterator (third current)))) + (package (first current)) + (type (second current)) + (iterator (si::hash-table-iterator (third current)))) (flet ((iterate () - (tagbody - AGAIN - (multiple-value-bind (found key value) - (funcall iterator) - (declare (ignore key)) - (cond - (found - (when (eq type :inherited) - (multiple-value-bind (s access) - (find-symbol (symbol-name value) package) - (unless (and (eq s value) (eq access type)) - (go AGAIN)))) - (return-from iterate (values t value type package))) - ((null all-symbols) - (return-from iterate (values nil nil nil nil))) - (t - (setq current (pop all-symbols)) - (setq package (first current) - type (second current) - iterator (si::hash-table-iterator (third current)) - )))) - (go AGAIN)))) - #'iterate)))) + (tagbody + AGAIN + (multiple-value-bind (found key value) + (funcall iterator) + (declare (ignore key)) + (cond + (found + (when (eq type :inherited) + (multiple-value-bind (s access) + (find-symbol (symbol-name value) package) + (unless (and (eq s value) (eq access type)) + (go AGAIN)))) + (return-from iterate (values t value type package))) + ((null all-symbols) + (return-from iterate (values nil nil nil nil))) + (t + (setq current (pop all-symbols)) + (setq package (first current) + type (second current) + iterator (si::hash-table-iterator (third current)) + )))) + (go AGAIN)))) + #'iterate)))) (defmacro with-package-iterator ((iterator package-list &rest conditions) - &rest body) + &rest body) (if conditions (let ((aux (set-difference conditions '(:external :internal :inherited)))) - (when aux - (signal-simple-error 'program-error nil "Clauses ~{~S~} are not allowed." - (list aux)))) + (when aux + (signal-simple-error 'program-error nil "Clauses ~{~S~} are not allowed." + (list aux)))) (signal-simple-error 'program-error - nil - "Must supply at least one of :inherited, :external or :internal" - nil)) + nil + "Must supply at least one of :inherited, :external or :internal" + nil)) `(let ((,iterator (packages-iterator ,package-list ',conditions t))) (macrolet ((,iterator () (list 'funcall ',iterator))) ,@body))) @@ -94,17 +94,17 @@ is used." (defun expand-do-symbols (var package result-form body options) (declare (si::c-local)) (let* ((i (gensym)) - (found (gensym)) - declaration doc) + (found (gensym)) + declaration doc) (multiple-value-setq (declaration body doc) (find-declarations body nil)) `(do* ((,i (packages-iterator ,package ',options t)) - ,found ,var) - (nil) - ,@declaration - (multiple-value-setq (,found ,var) (funcall ,i)) - (unless ,found (return ,result-form)) - ,@body))) + ,found ,var) + (nil) + ,@declaration + (multiple-value-setq (,found ,var) (funcall ,i)) + (unless ,found (return ,result-form)) + ,@body))) (defmacro do-symbols ((var &optional (package '*package*) (result-form nil)) &rest body) @@ -161,24 +161,24 @@ PACKAGE is non-NIL, then only the specified PACKAGE is searched." Returns a list of all symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified PACKAGE is searched." (sort (delete-duplicates (apropos-list-inner string package)) - #'(lambda (s1 s2) - (string-lessp (prin1-to-string s1) - (prin1-to-string s2))))) + #'(lambda (s1 s2) + (string-lessp (prin1-to-string s1) + (prin1-to-string s2))))) (defun apropos-list-inner (string package) (declare (si::c-local)) (let* ((list '()) - (string (string string))) + (string (string string))) (cond (package - (dolist (p (package-use-list package)) - (setf list (nconc (apropos-list-inner string p) list))) - (do-symbols (symbol package) - (when (search string (string symbol) :test #'char-equal) - (setq list (cons symbol list))))) - (t - (do-all-symbols (symbol) - (when (search string (string symbol) :test #'char-equal) - (setq list (cons symbol list)))))) + (dolist (p (package-use-list package)) + (setf list (nconc (apropos-list-inner string p) list))) + (do-symbols (symbol package) + (when (search string (string symbol) :test #'char-equal) + (setq list (cons symbol list))))) + (t + (do-all-symbols (symbol) + (when (search string (string symbol) :test #'char-equal) + (setq list (cons symbol list)))))) list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -193,30 +193,30 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched." ;; (declare (optimize speed)) (flet ((relative-to (package name) - (if (zerop (length name)) - package - (find-package (concatenate 'simple-string (package-name package) "." name)))) - (find-non-dot (name) - (do* ((len (length name)) - (i 0 (1+ i))) - ((= i len) nil) - (declare (fixnum len i)) - (when (char/= #\. (char name i)) (return i))))) + (if (zerop (length name)) + package + (find-package (concatenate 'simple-string (package-name package) "." name)))) + (find-non-dot (name) + (do* ((len (length name)) + (i 0 (1+ i))) + ((= i len) nil) + (declare (fixnum len i)) + (when (char/= #\. (char name i)) (return i))))) (when (and (stringp name) (plusp (length name)) (char= #\. (char name 0))) (let* ((last-dot-position (or (find-non-dot name) (length name))) - (n-dots (truly-the fixnum last-dot-position)) - (name (subseq name last-dot-position))) - ;; relative to our (- n-dots 1)'th parent - (let ((p *package*)) - (dotimes (i (1- n-dots)) - (declare (fixnum i)) - (let ((tmp (package-parent p))) - (unless tmp - (error "The parent of ~a does not exist." p)) - (setq p tmp))) - (relative-to p name)))))) + (n-dots (truly-the fixnum last-dot-position)) + (name (subseq name last-dot-position))) + ;; relative to our (- n-dots 1)'th parent + (let ((p *package*)) + (dotimes (i (1- n-dots)) + (declare (fixnum i)) + (let ((tmp (package-parent p))) + (unless tmp + (error "The parent of ~a does not exist." p)) + (setq p tmp))) + (relative-to p name)))))) (defun package-parent (package-specifier) ;; Given package-specifier, a package, symbol or string, return the @@ -226,24 +226,24 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched." ;; fast as possible. (declare (optimize speed)) (flet ((find-last-dot (name) - (do* ((len (1- (length name))) - (i len (1- i))) - ((= i -1) nil) - (declare (fixnum len i)) - (when (char= #\. (char name i)) (return i))))) + (do* ((len (1- (length name))) + (i len (1- i))) + ((= i -1) nil) + (declare (fixnum len i)) + (when (char= #\. (char name i)) (return i))))) (let* ((child (cond ((packagep package-specifier) - (package-name package-specifier)) - ((symbolp package-specifier) - (symbol-name package-specifier)) - ((stringp package-specifier) package-specifier) - (t (error "Illegal package specifier: ~s." - package-specifier)))) - (dot-position (find-last-dot child))) + (package-name package-specifier)) + ((symbolp package-specifier) + (symbol-name package-specifier)) + ((stringp package-specifier) package-specifier) + (t (error "Illegal package specifier: ~s." + package-specifier)))) + (dot-position (find-last-dot child))) (if dot-position - (let ((parent (subseq child 0 dot-position))) - (or (find-package parent) - (error "The parent of ~a does not exist." child)))) - (error "There is no parent of ~a." child)))) + (let ((parent (subseq child 0 dot-position))) + (or (find-package parent) + (error "The parent of ~a does not exist." child)))) + (error "There is no parent of ~a." child)))) (defun package-children (package-specifier &key (recurse t)) ;; Given package-specifier, a package, symbol or string, return all the @@ -257,28 +257,28 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched." (let* ((res ()) (parent (cond ((packagep package-specifier) (package-name package-specifier)) - ((symbolp package-specifier) - (symbol-name package-specifier)) - ((stringp package-specifier) package-specifier) - (t (error "Illegal package specifier: ~s." package-specifier)))) - (parent-prefix (concatenate 'simple-string parent "."))) + ((symbolp package-specifier) + (symbol-name package-specifier)) + ((stringp package-specifier) package-specifier) + (t (error "Illegal package specifier: ~s." package-specifier)))) + (parent-prefix (concatenate 'simple-string parent "."))) (labels - ((string-prefix-p (prefix string) - ;; Return length of `prefix' if `string' starts with `prefix'. - ;; We don't use `search' because it does much more than we need - ;; and this version is about 10x faster than calling `search'. - (let ((prefix-len (length prefix)) - (seq-len (length string))) - (declare (fixnum prefix-len seq-len)) - (when (>= prefix-len seq-len) - (return-from string-prefix-p nil)) - (do* ((i 0 (1+ i))) - ((= i prefix-len) prefix-len) - (declare (fixnum i)) - (when (not (char= (char prefix i) (char string i))) - (return nil)))))) + ((string-prefix-p (prefix string) + ;; Return length of `prefix' if `string' starts with `prefix'. + ;; We don't use `search' because it does much more than we need + ;; and this version is about 10x faster than calling `search'. + (let ((prefix-len (length prefix)) + (seq-len (length string))) + (declare (fixnum prefix-len seq-len)) + (when (>= prefix-len seq-len) + (return-from string-prefix-p nil)) + (do* ((i 0 (1+ i))) + ((= i prefix-len) prefix-len) + (declare (fixnum i)) + (when (not (char= (char prefix i) (char string i))) + (return nil)))))) (dolist (package (list-all-packages)) - (let* ((package-name (package-name package)) - (prefix (string-prefix-p parent-prefix package-name))) - (when (and prefix (or recurse (not (find #\. package-name :start prefix)))) - (pushnew package res))))))) + (let* ((package-name (package-name package)) + (prefix (string-prefix-p parent-prefix package-name))) + (when (and prefix (or recurse (not (find #\. package-name :start prefix)))) + (pushnew package res))))))) diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp index 7e5f4c352..df499a84c 100644 --- a/src/lsp/pprint.lsp +++ b/src/lsp/pprint.lsp @@ -37,18 +37,18 @@ ;; Where the output is going to finally go. ;; (target :initarg :target :initform t :type stream - :accessor pretty-stream-target) + :accessor pretty-stream-target) ;; ;; Line length we should format to. Cached here so we don't have to keep ;; extracting it from the target stream. (line-length :initform (or *print-right-margin* default-line-length) - :type column - :accessor pretty-stream-line-length) + :type column + :accessor pretty-stream-line-length) ;; ;; A simple string holding all the text that has been output but not yet ;; printed. (buffer :initform (make-string initial-buffer-size) :type simple-string - :accessor pretty-stream-buffer) + :accessor pretty-stream-buffer) ;; ;; The index into BUFFER where more text should be put. (buffer-fill-pointer :initform 0 :type index :accessor pretty-stream-buffer-fill-pointer) @@ -63,29 +63,29 @@ ;; zero, but if we end up with a very long line with no breaks in it we ;; might have to output part of it. Then this will no longer be zero. (buffer-start-column :initarg :buffer-start-column :type column - :accessor pretty-stream-buffer-start-column) + :accessor pretty-stream-buffer-start-column) ;; ;; The line number we are currently on. Used for *print-lines* abrevs and ;; to tell when sections have been split across multiple lines. (line-number :initform 0 :type index - :accessor pretty-stream-line-number) + :accessor pretty-stream-line-number) ;; ;; Stack of logical blocks in effect at the buffer start. (blocks :initform (list (make-logical-block)) :type list - :accessor pretty-stream-blocks) + :accessor pretty-stream-blocks) ;; ;; Buffer holding the per-line prefix active at the buffer start. ;; Indentation is included in this. The length of this is stored ;; in the logical block stack. (prefix :initform (make-string initial-buffer-size) :type string - :accessor pretty-stream-prefix) + :accessor pretty-stream-prefix) ;; ;; Buffer holding the total remaining suffix active at the buffer start. ;; The characters are right-justified in the buffer to make it easier ;; to output the buffer. The length is stored in the logical block ;; stack. (suffix :initform (make-string initial-buffer-size) :type string - :accessor pretty-stream-suffix) + :accessor pretty-stream-suffix) ;; ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) @@ -106,14 +106,14 @@ (defun make-pretty-stream (target) (make-instance 'pretty-stream :target target - :buffer-start-column (or (file-column target) 0) - )) + :buffer-start-column (or (file-column target) 0) + )) (defmethod print-object ((pretty-stream pretty-stream) stream) (print-unreadable-object (pretty-stream stream :type t :identity t)) #+nil (format stream "#" - (kernel:get-lisp-obj-address pretty-stream))) + (kernel:get-lisp-obj-address pretty-stream))) (declaim (inline index-posn posn-index posn-column)) (defun index-posn (index stream) @@ -143,47 +143,47 @@ (defun pretty-out (stream char) (declare (type pretty-stream stream) - (type character char) - (si::c-local)) + (type character char) + (si::c-local)) (cond ((char= char #\newline) - (enqueue-newline stream :literal)) - (t - (assure-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 + (assure-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 string string) - (type index start) - (type (or index null) end) - (si::c-local)) + (type string string) + (type index start) + (type (or index null) end) + (si::c-local)) (let ((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 (assure-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 (assure-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)))))))))) ;;;; Logical blocks. @@ -211,64 +211,64 @@ (defun really-start-logical-block (stream column prefix suffix) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (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) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (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)) @@ -276,14 +276,14 @@ (defun really-end-logical-block (stream) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream 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) @@ -295,50 +295,50 @@ (eval-when (:compile-toplevel :execute) (defmacro enqueue (stream type &rest args) (let ((constructor (intern (concatenate 'string - "MAKE-" - (symbol-name type))))) + "MAKE-" + (symbol-name type))))) (once-only ((stream stream) - (entry `(,constructor :posn - (index-posn - (pretty-stream-buffer-fill-pointer - (truly-the pretty-stream ,stream)) - ,stream) - ,@args)) - (op `(list ,entry)) - (head `(pretty-stream-queue-head (truly-the pretty-stream ,stream)))) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + (truly-the pretty-stream ,stream)) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head (truly-the pretty-stream ,stream)))) `(progn - (if ,head - (setf (cdr ,head) ,op) - (setf (pretty-stream-queue-tail (truly-the pretty-stream ,stream)) ,op)) - (setf (pretty-stream-queue-head (truly-the pretty-stream ,stream)) ,op) - ,entry)))) + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail (truly-the pretty-stream ,stream)) ,op)) + (setf (pretty-stream-queue-head (truly-the pretty-stream ,stream)) ,op) + ,entry)))) ) (defstruct (section-start - (:include queued-op)) + (:include queued-op)) (depth 0 :type index) (section-end nil :type (or null newline block-end))) (defstruct (newline - (:include section-start)) + (:include section-start)) (kind (required-argument) - :type (member :linear :fill :miser :literal :mandatory))) + :type (member :linear :fill :miser :literal :mandatory))) (defun enqueue-newline (stream kind) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (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)) + (:include queued-op)) (kind (required-argument) :type (member :block :current)) (amount 0 :type fixnum)) @@ -347,43 +347,43 @@ (enqueue stream indentation :kind kind :amount amount)) (defstruct (block-start - (:include section-start)) + (:include section-start)) (block-end nil :type (or null block-end)) (prefix nil :type (or null string)) (suffix nil :type (or null string))) (defun start-logical-block (stream prefix per-line-p suffix) (declare (si::c-local) - (type string prefix suffix) - (type pretty-stream stream) - (ext:check-arguments-type)) + (type string prefix suffix) + (type pretty-stream stream) + (ext:check-arguments-type)) (let ((prefix-len (length prefix))) (when (plusp prefix-len) (pretty-sout stream prefix 0 prefix-len)) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) - (start (enqueue stream block-start - :prefix (and (plusp prefix-len) per-line-p prefix) - :suffix (and (plusp (length suffix)) suffix) - :depth (length pending-blocks)))) + (start (enqueue stream block-start + :prefix (and (plusp prefix-len) per-line-p prefix) + :suffix (and (plusp (length suffix)) suffix) + :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) - (cons start pending-blocks))))) + (cons start pending-blocks))))) (defstruct (block-end - (:include queued-op)) + (:include queued-op)) (suffix nil :type (or null string))) (defun end-logical-block (stream) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream 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)) + (:include queued-op)) (sectionp nil :type (member t nil)) (relativep nil :type (member t nil)) (colnum 0 :type column) @@ -394,12 +394,12 @@ (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. @@ -407,295 +407,295 @@ (defun compute-tab-size (tab section-start column) (declare (si::c-local)) (let ((colnum (tab-colnum tab)) - (colinc (tab-colinc tab))) + (colinc (tab-colinc tab))) (when (tab-sectionp tab) (setf column (- column section-start))) (cond ((tab-relativep tab) - (unless (<= colinc 1) - (let ((newposn (+ column colnum))) - (let ((rem (rem newposn colinc))) - (unless (zerop rem) - (incf colnum (- colinc rem)))))) - colnum) - ((< column colnum) - (- colnum column)) - ((= column colnum) - colinc) - ((plusp colinc) - (- colinc (rem (- column colnum) colinc))) - (t - 0)))) + (unless (<= colinc 1) + (let ((newposn (+ column colnum))) + (let ((rem (rem newposn colinc))) + (unless (zerop rem) + (incf colnum (- colinc rem)))))) + colnum) + ((< column colnum) + (- colnum column)) + ((= column colnum) + colinc) + ((plusp colinc) + (- colinc (rem (- column colnum) colinc))) + (t + 0)))) (defun index-column (index stream) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream 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) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (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 assure-space-in-buffer (stream want) (declare (type pretty-stream stream) - (type index want) - (si::c-local)) + (type index want) + (si::c-local)) (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)) - (assure-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)) + (assure-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) - (si::c-local)) + (si::c-local)) (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)) (defun misering-p (stream) (declare (type pretty-stream stream) - (si::c-local)) + (si::c-local)) (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) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (let ((available (pretty-stream-line-length stream))) (when (and (not *print-readably*) *print-lines* - (= *print-lines* (pretty-stream-line-number stream))) + (= *print-lines* (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) - (si::c-local)) + (type newline until) + (si::c-local)) (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*) - *print-lines* (>= line-number *print-lines*)) - (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)) + *print-lines* (>= line-number *print-lines*)) + (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) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream 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) @@ -703,47 +703,47 @@ (defun force-pretty-output (stream) (declare (si::c-local) - (type pretty-stream stream)) + (type pretty-stream stream)) (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))) ;;;; Utilities. (defun pprint-pop-helper (object count stream &aux code) (cond ((not (listp object)) - (write-string ". " stream) - (write-object object stream) - nil) - ((and (not *print-readably*) - (eql count *print-length*)) - (write-string "..." stream) - nil) - ((or (null object) - (zerop count) - (fixnump object) - (characterp object) - (and (symbolp object) (symbol-package object)) - (null *circle-counter*)) - t) - ((eql 'NULL (setf code (gethash object *circle-stack* 'NULL))) - ;; We visit this part of the list for the first time and thus we must - ;; register it in the hash, or we are on the second pass and have - ;; found a completely new list. This should not happend, but anyway - ;; we try to print it. - (search-print-circle object) - t) - ((and (null code) (integerp *circle-counter*)) - ;; This object is not visited twice. - t) - (t - ;; In all other cases, WRITE-OBJECT - (write-string ". " stream) - (write-object object stream) - nil))) + (write-string ". " stream) + (write-object object stream) + nil) + ((and (not *print-readably*) + (eql count *print-length*)) + (write-string "..." stream) + nil) + ((or (null object) + (zerop count) + (fixnump object) + (characterp object) + (and (symbolp object) (symbol-package object)) + (null *circle-counter*)) + t) + ((eql 'NULL (setf code (gethash object *circle-stack* 'NULL))) + ;; We visit this part of the list for the first time and thus we must + ;; register it in the hash, or we are on the second pass and have + ;; found a completely new list. This should not happend, but anyway + ;; we try to print it. + (search-print-circle object) + t) + ((and (null code) (integerp *circle-counter*)) + ;; This object is not visited twice. + t) + (t + ;; In all other cases, WRITE-OBJECT + (write-string ". " stream) + (write-object object stream) + nil))) ;;;; User interface to the pretty printer. @@ -752,39 +752,39 @@ "Automatically handle *print-level* abbreviation. If we are too deep, then a # is printed to STREAM and BODY is ignored." (cond ((or *print-readably* (null *print-level*)) - t) - ((zerop *print-level*) - nil) - (t - (setf *print-level* (1- *print-level*))))) + t) + ((zerop *print-level*) + nil) + (t + (setf *print-level* (1- *print-level*))))) (defun search-print-circle (object) (declare (si::c-local)) (let ((code (gethash object *circle-stack* -1))) (if (fixnump *circle-counter*) - (cond ((or (eql code -1) (null code)) - ;; Is not referenced or was not found before - 0) - ((eql code t) - ;; Reference twice but had no code yet - (setf (gethash object *circle-stack*) - (setf *circle-counter* (1+ *circle-counter*))) - (- *circle-counter*)) - (t code)) - (cond ((eql code -1) - ;; Was not found before - (setf (gethash object *circle-stack*) nil) - 0) - ((null code) - ;; Second reference - (setf (gethash object *circle-stack*) t) - 1) - (t - ;; Further references - 2))))) + (cond ((or (eql code -1) (null code)) + ;; Is not referenced or was not found before + 0) + ((eql code t) + ;; Reference twice but had no code yet + (setf (gethash object *circle-stack*) + (setf *circle-counter* (1+ *circle-counter*))) + (- *circle-counter*)) + (t code)) + (cond ((eql code -1) + ;; Was not found before + (setf (gethash object *circle-stack*) nil) + 0) + ((null code) + ;; Second reference + (setf (gethash object *circle-stack*) t) + 1) + (t + ;; Further references + 2))))) (defun do-pprint-logical-block (function object stream prefix - per-line-prefix-p suffix) + per-line-prefix-p suffix) (declare (si::c-local)) (unless (listp object) (write-object object stream) @@ -793,69 +793,69 @@ (write-char #\# stream) (return-from do-pprint-logical-block nil)) (unless (or (not *print-circle*) - (fixnump object) - (characterp object) - (and (symbolp object) (symbol-package object))) + (fixnump object) + (characterp object) + (and (symbolp object) (symbol-package object))) (let (code) (cond ((not *circle-counter*) - (let* ((hash (make-hash-table :test 'eq :size 1024 - :rehash-size 1.5 - :rehash-threshold 0.75)) - (*circle-counter* t) - (*circle-stack* hash)) - (do-pprint-logical-block function object - (make-pretty-stream (make-broadcast-stream)) - prefix per-line-prefix-p suffix) - (setf *circle-counter* 0) - (do-pprint-logical-block function object stream - prefix per-line-prefix-p suffix)) - (return-from do-pprint-logical-block nil)) - ((zerop (setf code (search-print-circle object))) - ;; Object was not referenced before: we must either traverse it - ;; or print it. - ) - ((minusp code) - ;; First definition, we write the #n=... prefix - (write-string "#" stream) - (let ((*print-radix* nil) (*print-base* 10)) - (write-ugly-object (- code) stream)) - (write-string "=" stream)) - (t - ;; Further references, we write the #n# tag and exit - (write-string "#" stream) - (let ((*print-radix* nil) (*print-base* 10)) - (write-ugly-object code stream)) - (write-string "#" stream) - (return-from do-pprint-logical-block nil))))) + (let* ((hash (make-hash-table :test 'eq :size 1024 + :rehash-size 1.5 + :rehash-threshold 0.75)) + (*circle-counter* t) + (*circle-stack* hash)) + (do-pprint-logical-block function object + (make-pretty-stream (make-broadcast-stream)) + prefix per-line-prefix-p suffix) + (setf *circle-counter* 0) + (do-pprint-logical-block function object stream + prefix per-line-prefix-p suffix)) + (return-from do-pprint-logical-block nil)) + ((zerop (setf code (search-print-circle object))) + ;; Object was not referenced before: we must either traverse it + ;; or print it. + ) + ((minusp code) + ;; First definition, we write the #n=... prefix + (write-string "#" stream) + (let ((*print-radix* nil) (*print-base* 10)) + (write-ugly-object (- code) stream)) + (write-string "=" stream)) + (t + ;; Further references, we write the #n# tag and exit + (write-string "#" stream) + (let ((*print-radix* nil) (*print-base* 10)) + (write-ugly-object code stream)) + (write-string "#" stream) + (return-from do-pprint-logical-block nil))))) (let ((*print-level* (and (not *print-readably*) - *print-level* - (1- *print-level*)))) + *print-level* + (1- *print-level*)))) (start-logical-block stream prefix per-line-prefix-p suffix) (funcall function object stream) (end-logical-block stream)) nil) (defun pprint-logical-block-helper (function object stream prefix - per-line-prefix-p suffix) + per-line-prefix-p suffix) (setf stream (case stream - ((nil) *standard-output*) - ((t) *terminal-io*) - (t stream))) + ((nil) *standard-output*) + ((t) *terminal-io*) + (t stream))) (if (pretty-stream-p stream) (do-pprint-logical-block function object stream prefix - per-line-prefix-p suffix) + per-line-prefix-p suffix) (let ((stream (make-pretty-stream stream))) - (catch 'line-limit-abbreviation-happened - (do-pprint-logical-block function object stream prefix - per-line-prefix-p suffix) - (force-pretty-output stream)) - nil))) + (catch 'line-limit-abbreviation-happened + (do-pprint-logical-block function object stream prefix + per-line-prefix-p suffix) + (force-pretty-output stream)) + nil))) (defmacro pprint-logical-block - ((stream-symbol object &key (prefix "" prefix-p) - (per-line-prefix "" per-line-prefix-p) - (suffix "" suffix-p)) - &body body) + ((stream-symbol object &key (prefix "" prefix-p) + (per-line-prefix "" per-line-prefix-p) + (suffix "" suffix-p)) + &body body) "Group some output into a logical block. STREAM-SYMBOL should be either a stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer control variable *PRINT-LEVEL* is automatically handled." @@ -865,31 +865,31 @@ (error "Cannot specify both a prefix and a per-line-prefix.")) (setf prefix per-line-prefix)) (let* ((object-var (gensym)) - (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) - (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) - (stream-var (case stream-symbol - ((nil) '*standard-output*) - ((t) '*terminal-io*) - (t stream-symbol))) - (function - `(ext::lambda-block ,block-name (,object-var ,stream-var - &aux (,count-name 0)) + (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) + (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) + (stream-var (case stream-symbol + ((nil) '*standard-output*) + ((t) '*terminal-io*) + (t stream-symbol))) + (function + `(ext::lambda-block ,block-name (,object-var ,stream-var + &aux (,count-name 0)) (declare (ignorable ,object-var ,stream-var ,count-name)) - (macrolet ((pprint-pop () - '(progn - (unless (pprint-pop-helper ,object-var ,count-name - ,stream-var) - (return-from ,block-name nil)) - (incf ,count-name) - ,(if object `(pop ,object-var) nil))) - (pprint-exit-if-list-exhausted () - ,(if object - `'(when (null ,object-var) - (return-from ,block-name nil)) - `'(return-from ,block-name nil)))) - ,@body)))) + (macrolet ((pprint-pop () + '(progn + (unless (pprint-pop-helper ,object-var ,count-name + ,stream-var) + (return-from ,block-name nil)) + (incf ,count-name) + ,(if object `(pop ,object-var) nil))) + (pprint-exit-if-list-exhausted () + ,(if object + `'(when (null ,object-var) + (return-from ,block-name nil)) + `'(return-from ,block-name nil)))) + ,@body)))) `(pprint-logical-block-helper #',function ,object ,stream-symbol - ,prefix ,per-line-prefix-p ,suffix))) + ,prefix ,per-line-prefix-p ,suffix))) (defmacro pprint-exit-if-list-exhausted () "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return @@ -898,7 +898,7 @@ PPRINT-LOGICAL-BLOCK is supplied." (declare #.+ecl-safe-declarations+) (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~ - PPRINT-LOGICAL-BLOCK.")) + PPRINT-LOGICAL-BLOCK.")) (defmacro pprint-pop () "Return the next element from LIST argument to the closest enclosing @@ -929,13 +929,13 @@ 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) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (type (or stream (member t nil)) stream) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-newline stream kind))) nil) @@ -951,14 +951,14 @@ The new indention 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) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (type real n) + (type (or stream (member t nil)) stream) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-indent stream relative-to (round n)))) nil) @@ -976,14 +976,14 @@ :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) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (type unsigned-byte colnum colinc) + (type (or stream (member t nil)) stream) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-tab stream kind colnum colinc))) nil) @@ -995,11 +995,11 @@ can be used with the ~/.../ format directive." (declare (ignore atsign?) (type (or stream (member t nil)) stream) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (write-object (pprint-pop) stream) @@ -1014,11 +1014,11 @@ can be used with the ~/.../ format directive." (declare (ignore atsign?) (type (or stream (member t nil)) stream) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (write-object (pprint-pop) stream) @@ -1035,11 +1035,11 @@ the ~/.../ format directive." (declare (ignore atsign?) (type (or stream (member t nil)) stream) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (write-object (pprint-pop) stream) @@ -1055,7 +1055,7 @@ (defvar *initial-pprint-dispatch*) (defstruct (pprint-dispatch-entry - (:print-function %print-pprint-dispatch-entry)) + (:print-function %print-pprint-dispatch-entry)) ;; ;; The type specifier for this entry. (type (required-argument) :type t) @@ -1073,12 +1073,12 @@ (declare (ignore depth)) (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)))) (defstruct (pprint-dispatch-table - (:print-function %print-pprint-dispatch-table)) + (:print-function %print-pprint-dispatch-table)) ;; Are we allowed to modify this table? (read-only-p nil) ;; @@ -1102,37 +1102,37 @@ (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) - (si::c-local)) + (si::c-local)) (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))))) (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table) - #.+ecl-safe-declarations+) + #.+ecl-safe-declarations+) (let* ((orig (or table *initial-pprint-dispatch*))) (let* ((new (make-pprint-dispatch-table - :entries (copy-list (pprint-dispatch-table-entries orig)))) - (new-cons-entries (pprint-dispatch-table-cons-entries new))) + :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 default-pprint-dispatch (stream object) @@ -1140,74 +1140,74 @@ (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) + (ext:check-arguments-type) + #.+ecl-safe-declarations+) (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 (typep object (pprint-dispatch-entry-type entry)) - (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 (typep object (pprint-dispatch-entry-type entry)) + (return entry))))) (if entry - (values (pprint-dispatch-entry-function entry) t) - (values #'default-pprint-dispatch nil)))) + (values (pprint-dispatch-entry-function entry) t) + (values #'default-pprint-dispatch nil)))) (defun set-pprint-dispatch (type function &optional - (priority 0) (table *print-pprint-dispatch*)) + (priority 0) (table *print-pprint-dispatch*)) (declare (type t type) (type (or null function symbol) function) - (type real priority) - (type pprint-dispatch-table table) - #.+ecl-safe-declarations+) + (type real priority) + (type pprint-dispatch-table table) + #.+ecl-safe-declarations+) (when (pprint-dispatch-table-read-only-p table) (cerror "Ignore and continue" - "Tried to modified a read-only pprint dispatch table: ~A" - table)) + "Tried to modified a read-only pprint dispatch table: ~A" + table)) ;; FIXME! This check should be automatically generated when compiling ;; with high enough safety mode. (unless (typep priority 'real) (error 'simple-type-error - :format-control "Not a valid priority for set-pprint-dispatch: ~A" - :format-arguments (list priority) - :expected-type 'real - :datum priority)) + :format-control "Not a valid priority for set-pprint-dispatch: ~A" + :format-arguments (list priority) + :expected-type 'real + :datum priority)) (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 - :function function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type - :priority priority :function function))) - (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) - (if prev - (setf (cdr prev) (cons entry next)) - (setf list (cons entry next))) - (return))) - (setf (pprint-dispatch-table-entries table) list))) + (setf (gethash (second (second type)) + (pprint-dispatch-table-cons-entries table)) + (make-pprint-dispatch-entry :type type :priority priority + :function function)) + (let ((list (delete type (pprint-dispatch-table-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal)) + (entry (make-pprint-dispatch-entry + :type type + :priority priority :function function))) + (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) + (if prev + (setf (cdr prev) (cons entry next)) + (setf list (cons entry next))) + (return))) + (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)))) nil) @@ -1215,48 +1215,48 @@ (defun pprint-array (stream array) (cond ((or (and (null *print-array*) (null *print-readably*)) - (stringp array) - (bit-vector-p array)) - (write-ugly-object array stream)) - (*print-readably* - (pprint-raw-array stream array)) - ((vectorp array) - (pprint-vector stream array)) - (t - (pprint-multi-dim-array stream array)))) + (stringp array) + (bit-vector-p array)) + (write-ugly-object array stream)) + (*print-readably* + (pprint-raw-array stream 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) - (write-char #\space stream) - (pprint-newline :fill stream)) + (write-char #\space stream) + (pprint-newline :fill stream)) (pprint-pop) (write-object (aref vector i) stream)))) (defun pprint-array-contents (stream array) (declare (si::c-local) - (array array)) + (array array)) (labels ((output-guts (stream index dimensions) - (if (null dimensions) - (write-object (row-major-aref array 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) + (write-object (row-major-aref array 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 0 (array-dimensions array)))) (defun pprint-multi-dim-array (stream array) @@ -1280,62 +1280,62 @@ (declare (ignore noise)) (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) - (write-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) - (write-object (pprint-pop) stream))) - (pprint-lambda-list stream (pprint-pop))) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (write-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) + (write-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) + (write-object (pprint-pop) stream))) + (pprint-lambda-list stream (pprint-pop))) + (loop + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (write-object (pprint-pop) stream)))))) + (setf first nil))))) (defun pprint-lambda (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream list)) + "~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") + stream list)) (defun pprint-block (stream list &rest noise) (declare (ignore noise)) @@ -1344,15 +1344,15 @@ (defun pprint-flet (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") - stream - list)) + "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") + stream + list)) (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)) @@ -1361,22 +1361,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) - (write-object (cadr list) stream)) - (quote - (write-char #\' stream) - (write-object (cadr list) stream)) - (t - (pprint-fill stream list))) + (function + (write-string "#'" stream) + (write-object (cadr list) stream)) + (quote + (write-char #\' stream) + (write-object (cadr list) stream)) + (t + (pprint-fill stream list))) (pprint-fill stream list))) (defun pprint-setq (stream list &rest noise) @@ -1388,24 +1388,24 @@ (write-char #\space stream) (pprint-newline :miser stream) (if (and (consp (cdr list)) (consp (cddr list))) - (loop - (pprint-indent :current 2 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-indent :current -2 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)) - (progn - (pprint-indent :current 0 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (write-object (pprint-pop) stream))))) + (loop + (pprint-indent :current 2 stream) + (write-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (pprint-indent :current -2 stream) + (write-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream)) + (progn + (pprint-indent :current 0 stream) + (write-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (write-object (pprint-pop) stream))))) #+ecl-min (defmacro pprint-tagbody-guts (stream) @@ -1414,8 +1414,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) (write-object form-or-tag ,stream)))) @@ -1429,22 +1429,22 @@ (defun pprint-case (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") - stream - list)) + "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") + stream + list)) (defun pprint-defun (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream - list)) + "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") + stream + list)) (defun pprint-destructuring-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) + "~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") + stream list)) (defun pprint-do (stream list &rest noise) (declare (ignore noise)) @@ -1455,8 +1455,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) @@ -1473,16 +1473,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)) @@ -1498,8 +1498,8 @@ (defun pprint-function-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") - stream - list)) + stream + list)) ;;;; Interface seen by regular (ugly) printer and initialization routines. @@ -1592,16 +1592,16 @@ ;; Printers for regular types. (set-pprint-dispatch 'array #'pprint-array) (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - #'pprint-function-call -1) + #'pprint-function-call -1) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; Cons cells with interesting things for the car. (dolist (magic-form '#.+magic-forms+) (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) + (symbol-function (second magic-form)))) (setf *initial-pprint-dispatch* *print-pprint-dispatch*) ) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil) - *standard-pprint-dispatch* *initial-pprint-dispatch*) + *standard-pprint-dispatch* *initial-pprint-dispatch*) (setf (pprint-dispatch-table-read-only-p *standard-pprint-dispatch*) t) (setf (first (cdr si::+io-syntax-progv-list+)) *standard-pprint-dispatch*) (setf (first (cdr si::+ecl-syntax-progv-list+)) *standard-pprint-dispatch*) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index dc8358ad4..bacf3f02b 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -57,7 +57,7 @@ Builds a new function which accepts any number of arguments but always outputs N (defmacro deftype (name lambda-list &rest body &environment env) "Syntax: (deftype name lambda-list {decl | doc}* {form}*) Defines a new type-specifier abbreviation in terms of an 'expansion' function - (lambda lambda-list1 {DECL}* {FORM}*) + (lambda lambda-list1 {DECL}* {FORM}*) where LAMBDA-LIST1 is identical to LAMBDA-LIST except that all optional parameters with no default value specified in LAMBDA-LIST defaults to the symbol '*', but not to NIL. When the type system of ECL encounters a type @@ -72,11 +72,11 @@ by (documentation 'NAME 'type)." (setf lambda-list (copy-list lambda-list)) (dolist (x '(&optional &key)) (do ((l (rest (member x lambda-list)) (rest l))) - ((null l)) - (let ((variable (first l))) - (when (and (symbolp variable) - (not (member variable lambda-list-keywords))) - (setf (first l) `(,variable '*)))))) + ((null l)) + (let ((variable (first l))) + (when (and (symbolp variable) + (not (member variable lambda-list-keywords))) + (setf (first l) `(,variable '*)))))) (let ((function `#'(LAMBDA-BLOCK ,name ,lambda-list ,@body))) (when (and (null lambda-list) (consp body) (null (rest body))) (let ((form (first body))) @@ -118,30 +118,30 @@ bignums." (deftype real (&optional (start '* start-p) (end '*)) (if start-p (let (rat-start - real-start - rat-end - real-end) - (cond ((consp start) - (setf start (first start) - rat-start (list (rational start)) - real-start (list (float start)))) - ((numberp start) - (setf rat-start (rational start) - real-start (float start))) - (t - (setf rat-start start - real-start start))) - (cond ((consp end) - (setf end (first end) - rat-end (list (rational end)) - real-end (list (float end)))) - ((numberp end) - (setf rat-end (rational end) - real-end (float end))) - (t - (setf rat-end end - real-end end))) - `(OR (RATIONAL ,rat-start ,rat-end) (FLOAT ,real-start ,real-end))) + real-start + rat-end + real-end) + (cond ((consp start) + (setf start (first start) + rat-start (list (rational start)) + real-start (list (float start)))) + ((numberp start) + (setf rat-start (rational start) + real-start (float start))) + (t + (setf rat-start start + real-start start))) + (cond ((consp end) + (setf end (first end) + rat-end (list (rational end)) + real-end (list (float end)))) + ((numberp end) + (setf rat-end (rational end) + real-end (float end))) + (t + (setf rat-end end + real-end end))) + `(OR (RATIONAL ,rat-start ,rat-end) (FLOAT ,real-start ,real-end))) '(OR RATIONAL FLOAT))) #-short-float @@ -192,13 +192,13 @@ or a cons whose cdr is a list, and is notated by its elements surrounded with parentheses. The backquote macro is sometimes useful to construct a complicated list structure. When evaluating `(...) - ,form embeds the value of FORM, - ,@form and ,.form embed all elements of the list value of FORM, - and other things embed itself + ,form embeds the value of FORM, + ,@form and ,.form embed all elements of the list value of FORM, + and other things embed itself into the structure at their position. For example, - `(a b ,c d e) expands to (list* 'a 'b c '(d e)) - `(a b ,@c d e) expands to (list* 'a 'b (append c '(d e))) - `(a b ,.c d e) expands to (list* 'a 'b (nconc c '(d e)))" + `(a b ,c d e) expands to (list* 'a 'b c '(d e)) + `(a b ,@c d e) expands to (list* 'a 'b (append c '(d e))) + `(a b ,.c d e) expands to (list* 'a 'b (nconc c '(d e)))" '(OR CONS NULL)) (deftype proper-list () @@ -215,7 +215,7 @@ into the structure at their position. For example, (deftype vector (&optional (element-type '*) (size '*)) "A vector is a one-dimensional array. Strings and bit-vectors are kinds of vectors. Other vectors are called general vectors and are notated as - #(elem ... elem) + #(elem ... elem) Some vectors may be displaced to another array, may have a fill-pointer, or may be adjustable. Other vectors are called simple-vectors." `(array ,element-type (,size))) @@ -237,7 +237,7 @@ called simple-strings." (if (eq size '*) '(or (array base-char (*)) (array character (*))) `(or (array base-char (,size)) - (array character (,size))))) + (array character (,size))))) (deftype base-string (&optional (size '*)) "A string which is made of BASE-CHAR." @@ -273,7 +273,7 @@ fill-pointer, and is not adjustable." #+unicode (if size `(or (simple-array base-char (,size)) - (simple-array character (,size))) + (simple-array character (,size))) '(or (simple-array base-char (*)) (simple-array character (*))))) (deftype simple-base-string (&optional size) @@ -289,7 +289,7 @@ and is not adjustable." '(integer 0 #.(1- array-dimension-limit))) ;;************************************************************ -;; TYPEP +;; TYPEP ;;************************************************************ (defun simple-array-p (x) @@ -301,8 +301,8 @@ and is not adjustable." (defun complex-array-p (x) (and (arrayp x) (or (adjustable-array-p x) - (array-has-fill-pointer-p x) - (array-displacement x)))) + (array-has-fill-pointer-p x) + (array-displacement x)))) (defun ratiop (x) #-ecl-min @@ -408,26 +408,26 @@ and is not adjustable." (defun upgraded-array-element-type (element-type &optional env) (declare (ignore env)) (let* ((hash (logand 127 (si:hash-eql element-type))) - (record (aref *upgraded-array-element-type-cache* hash))) + (record (aref *upgraded-array-element-type-cache* hash))) (declare (type (integer 0 127) hash)) (if (and record (eq (car record) element-type)) - (cdr record) - (let ((answer (if (member element-type +upgraded-array-element-types+ - :test #'eq) - element-type - (dolist (v +upgraded-array-element-types+ 'T) - (when (subtypep element-type v) - (return v)))))) - (setf (aref *upgraded-array-element-type-cache* hash) - (cons element-type answer)) - answer)))) + (cdr record) + (let ((answer (if (member element-type +upgraded-array-element-types+ + :test #'eq) + element-type + (dolist (v +upgraded-array-element-types+ 'T) + (when (subtypep element-type v) + (return v)))))) + (setf (aref *upgraded-array-element-type-cache* hash) + (cons element-type answer)) + answer)))) (defun upgraded-complex-part-type (real-type &optional env) (declare (ignore env)) ;; ECL does not have specialized complex types. If we had them, the ;; code would look as follows ;; (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL) - ;; (error "~S is not a valid part type for a complex." real-type)) + ;; (error "~S is not a valid part type for a complex." real-type)) ;; (when (subtypep real-type v) ;; (return v)))) (unless (subtypep real-type 'REAL) @@ -460,40 +460,40 @@ and is not adjustable." (declare (si::c-local)) (or (eq pat '*) (let ((rank (array-rank array))) - (cond ((numberp pat) (= rank pat)) - ((listp pat) - (dotimes (i rank (null pat)) - (unless (and (consp pat) - (or (eq (car pat) '*) - (eql (array-dimension array i) (car pat)))) - (return nil)) - (setq pat (cdr pat)))) - ((atom pat) - (error "~S does not describe array dimensions." pat)))))) + (cond ((numberp pat) (= rank pat)) + ((listp pat) + (dotimes (i rank (null pat)) + (unless (and (consp pat) + (or (eq (car pat) '*) + (eql (array-dimension array i) (car pat)))) + (return nil)) + (setq pat (cdr pat)))) + ((atom pat) + (error "~S does not describe array dimensions." pat)))))) (defun typep (object type &optional env &aux tp i c) "Args: (object type) Returns T if X belongs to TYPE; NIL otherwise." (declare (ignore env)) (cond ((symbolp type) - (let ((f (get-sysprop type 'TYPE-PREDICATE))) - (if f - (return-from typep (funcall f object)) - (setq tp type i nil)))) - ((consp type) - (setq tp (car type) i (cdr type))) - #+clos - ((sys:instancep type) - (return-from typep (si::subclassp (class-of object) type))) - (t - (error-type-specifier type))) + (let ((f (get-sysprop type 'TYPE-PREDICATE))) + (if f + (return-from typep (funcall f object)) + (setq tp type i nil)))) + ((consp type) + (setq tp (car type) i (cdr type))) + #+clos + ((sys:instancep type) + (return-from typep (si::subclassp (class-of object) type))) + (t + (error-type-specifier type))) (case tp ((EQL MEMBER) (and (member object i) t)) (NOT (not (typep object (car i)))) (OR (dolist (e i) - (when (typep object e) (return t)))) + (when (typep object e) (return t)))) (AND (dolist (e i t) - (unless (typep object e) (return nil)))) + (unless (typep object e) (return nil)))) (SATISFIES (funcall (car i) object)) ((T) t) ((NIL) nil) @@ -520,19 +520,19 @@ Returns T if X belongs to TYPE; NIL otherwise." (COMPLEX (and (complexp object) (or (null i) - (and (typep (realpart object) (car i)) - ;;wfs--should only have to check one. - ;;Illegal to mix real and imaginary types! - (typep (imagpart object) (car i)))) - )) + (and (typep (realpart object) (car i)) + ;;wfs--should only have to check one. + ;;Illegal to mix real and imaginary types! + (typep (imagpart object) (car i)))) + )) (SEQUENCE (or (listp object) (vectorp object))) (CONS (and (consp object) - (or (endp i) - (let ((car-type (first i))) - (or (eq car-type '*) (typep (car object) car-type)))) - (or (endp (cdr i)) - (let ((cdr-type (second i))) - (or (eq cdr-type '*) (typep (cdr object) cdr-type)))))) + (or (endp i) + (let ((car-type (first i))) + (or (eq car-type '*) (typep (car object) car-type)))) + (or (endp (cdr i)) + (let ((cdr-type (second i))) + (or (eq cdr-type '*) (typep (cdr object) cdr-type)))))) (BASE-STRING (and (base-string-p object) (or (null i) (match-dimensions object i)))) @@ -545,7 +545,7 @@ Returns T if X belongs to TYPE; NIL otherwise." (SIMPLE-BASE-STRING (and (base-string-p object) (simple-string-p object) - (or (null i) (match-dimensions object i)))) + (or (null i) (match-dimensions object i)))) (SIMPLE-STRING (and (simple-string-p object) (or (null i) (match-dimensions object i)))) @@ -558,16 +558,16 @@ Returns T if X belongs to TYPE; NIL otherwise." (COMPLEX-ARRAY (and (complex-array-p object) (or (endp i) (eq (car i) '*) - ;; (car i) needs expansion - (eq (array-element-type object) - (upgraded-array-element-type (car i)))) + ;; (car i) needs expansion + (eq (array-element-type object) + (upgraded-array-element-type (car i)))) (or (endp (cdr i)) (match-dimensions object (second i))))) (SIMPLE-ARRAY (and (simple-array-p object) (or (endp i) (eq (car i) '*) - ;; (car i) needs expansion - (eq (array-element-type object) - (upgraded-array-element-type (car i)))) + ;; (car i) needs expansion + (eq (array-element-type object) + (upgraded-array-element-type (car i)))) (or (endp (cdr i)) (match-dimensions object (second i))))) (ARRAY (and (arrayp object) @@ -575,54 +575,54 @@ Returns T if X belongs to TYPE; NIL otherwise." ;; Or the element type of object should be EQUAL to (car i). ;; Is this too strict? (eq (array-element-type object) - (upgraded-array-element-type (car i)))) + (upgraded-array-element-type (car i)))) (or (endp (cdr i)) (match-dimensions object (second i))))) (t (cond ((get-sysprop tp 'DEFTYPE-DEFINITION) (typep object (apply (get-sysprop tp 'DEFTYPE-DEFINITION) i))) - ((consp i) - (error-type-specifier type)) + ((consp i) + (error-type-specifier type)) #+clos - ((setq c (find-class type nil)) - ;; Follow the inheritance chain - (si::subclassp (class-of object) c)) - #-clos - ((get-sysprop tp 'IS-A-STRUCTURE) + ((setq c (find-class type nil)) + ;; Follow the inheritance chain + (si::subclassp (class-of object) c)) + #-clos + ((get-sysprop tp 'IS-A-STRUCTURE) (when (sys:structurep object) - ;; Follow the chain of structure-include. - (do ((stp (sys:structure-name object) - (get-sysprop stp 'STRUCTURE-INCLUDE))) - ((eq tp stp) t) - (when (null (get-sysprop stp 'STRUCTURE-INCLUDE)) - (return nil))))) - (t - (error-type-specifier type)))))) + ;; Follow the chain of structure-include. + (do ((stp (sys:structure-name object) + (get-sysprop stp 'STRUCTURE-INCLUDE))) + ((eq tp stp) t) + (when (null (get-sysprop stp 'STRUCTURE-INCLUDE)) + (return nil))))) + (t + (error-type-specifier type)))))) #+clos (defun subclassp (low high) (or (eq low high) (member high (sys:instance-ref low clos::+class-precedence-list-ndx+) - :test #'eq))) ; (class-precedence-list low) + :test #'eq))) ; (class-precedence-list low) #+clos (defun of-class-p (object class) (declare (optimize (speed 3) (safety 0))) (macrolet ((class-precedence-list (x) - `(si::instance-ref ,x clos::+class-precedence-list-ndx+)) - (class-name (x) - `(si::instance-ref ,x clos::+class-name-ndx+))) + `(si::instance-ref ,x clos::+class-precedence-list-ndx+)) + (class-name (x) + `(si::instance-ref ,x clos::+class-name-ndx+))) (let* ((x-class (class-of object))) (declare (class x-class)) (if (eq x-class class) - t - (let ((x-cpl (class-precedence-list x-class))) - (if (instancep class) - (member class x-cpl :test #'eq) - (dolist (c x-cpl) - (declare (class c)) - (when (eq (class-name c) class) - (return t))))))))) + t + (let ((x-cpl (class-precedence-list x-class))) + (if (instancep class) + (member class x-cpl :test #'eq) + (dolist (c x-cpl) + (declare (class c)) + (when (eq (class-name c) class) + (return t))))))))) #+(and clos ecl-min) (defun clos::classp (foo) @@ -630,7 +630,7 @@ Returns T if X belongs to TYPE; NIL otherwise." nil) ;;************************************************************ -;; NORMALIZE-TYPE +;; NORMALIZE-TYPE ;;************************************************************ ;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. ;; The result is a pair of values @@ -639,38 +639,38 @@ Returns T if X belongs to TYPE; NIL otherwise." (defun normalize-type (type &aux tp i fd) ;; Loops until the car of type has no DEFTYPE definition. (cond ((symbolp type) - (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION)) - (normalize-type (funcall fd)) - (values type nil))) - #+clos - ((clos::classp type) (values type nil)) - ((atom type) - (error-type-specifier type)) - ((progn - (setq tp (car type) i (cdr type)) - (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION))) - (normalize-type (apply fd i))) - ((and (eq tp 'INTEGER) (consp (cadr i))) - (values tp (list (car i) (1- (caadr i))))) - (t (values tp i)))) + (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION)) + (normalize-type (funcall fd)) + (values type nil))) + #+clos + ((clos::classp type) (values type nil)) + ((atom type) + (error-type-specifier type)) + ((progn + (setq tp (car type) i (cdr type)) + (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION))) + (normalize-type (apply fd i))) + ((and (eq tp 'INTEGER) (consp (cadr i))) + (values tp (list (car i) (1- (caadr i))))) + (t (values tp i)))) (defun expand-deftype (type) (cond ((symbolp type) - (let ((fd (get-sysprop type 'DEFTYPE-DEFINITION))) - (if fd - (expand-deftype (funcall fd)) - type))) - ((and (consp type) - (symbolp type)) - (let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION))) - (if fd - (expand-deftype (funcall fd (rest type))) - type))) - (t - type))) + (let ((fd (get-sysprop type 'DEFTYPE-DEFINITION))) + (if fd + (expand-deftype (funcall fd)) + type))) + ((and (consp type) + (symbolp type)) + (let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION))) + (if fd + (expand-deftype (funcall fd (rest type))) + type))) + (t + type))) ;;************************************************************ -;; COERCE +;; COERCE ;;************************************************************ (defun coerce (object type &aux aux) @@ -727,7 +727,7 @@ if not possible." (fail)))))) ;;************************************************************ -;; SUBTYPEP +;; SUBTYPEP ;;************************************************************ ;; ;; TYPES LATTICE (Following Henry Baker's paper) @@ -736,10 +736,10 @@ if not possible." ;; are elementary, in the sense that other types may be expressed as ;; combination of them. We partition these sets into FAMILIES ;; -;; Built-in objects --- Hash tables, etc -;; Intervals --- (INTEGER a b), (REAL a b), etc -;; Arrays --- (ARRAY * (2)), etc -;; Classes +;; Built-in objects --- Hash tables, etc +;; Intervals --- (INTEGER a b), (REAL a b), etc +;; Arrays --- (ARRAY * (2)), etc +;; Classes ;; ;; When passed a type specifier, ECL canonicalizes it: it decomposes the ;; type into the most elementary sets, assigns a unique bit pattern (TAG) to @@ -747,9 +747,9 @@ if not possible." ;; Operations between these sets reduce to logical operations between these ;; bit patterns. Given types T1, T2 and a function which produces tags f(T) ;; -;; f((AND T1 T2)) = (LOGIAND f(T1) f(T2)) -;; f((OR T1 T2)) = (LOGIOR f(T1) f(T2)) -;; f((NOT T1)) = (LOGNOT f(T2)) +;; f((AND T1 T2)) = (LOGIAND f(T1) f(T2)) +;; f((OR T1 T2)) = (LOGIOR f(T1) f(T2)) +;; f((NOT T1)) = (LOGNOT f(T2)) ;; ;; However, tags are not permanent: whenever a new type is registered, the ;; tag associated to a type may be changed (for instance, because new @@ -792,8 +792,8 @@ if not possible." (declare (si::c-local)) (when *save-types-database* (setf *save-types-database* nil - *elementary-types* (copy-tree *elementary-types*) - *member-types* (copy-tree *member-types*)))) + *elementary-types* (copy-tree *elementary-types*) + *member-types* (copy-tree *member-types*)))) ;; We have created and tagged a new type (NEW-TAG). However, there are ;; composite and synonym types registered around which are supertypes of @@ -823,27 +823,27 @@ if not possible." (defun find-type-bounds (type in-our-family-p type-<= minimize-super) (declare (si::c-local) (optimize (safety 0)) - (function in-our-family-p type-<=)) + (function in-our-family-p type-<=)) (let* ((subtype-tag 0) - (disjoint-tag 0) - (supertype-tag (if minimize-super -1 0))) + (disjoint-tag 0) + (supertype-tag (if minimize-super -1 0))) (dolist (i *elementary-types*) (declare (cons i)) (let ((other-type (car i)) - (other-tag (cdr i))) - (when (funcall in-our-family-p other-type) - (cond ((funcall type-<= type other-type) - (if minimize-super - (when (zerop (logandc2 other-tag supertype-tag)) - (setq supertype-tag other-tag)) - (setq supertype-tag (logior other-tag supertype-tag)))) - ((funcall type-<= other-type type) - (setq subtype-tag (logior other-tag subtype-tag))) - (t - (setq disjoint-tag (logior disjoint-tag other-tag))))))) + (other-tag (cdr i))) + (when (funcall in-our-family-p other-type) + (cond ((funcall type-<= type other-type) + (if minimize-super + (when (zerop (logandc2 other-tag supertype-tag)) + (setq supertype-tag other-tag)) + (setq supertype-tag (logior other-tag supertype-tag)))) + ((funcall type-<= other-type type) + (setq subtype-tag (logior other-tag subtype-tag))) + (t + (setq disjoint-tag (logior disjoint-tag other-tag))))))) (values (if (= supertype-tag -1) 0 - (logandc2 supertype-tag (logior disjoint-tag subtype-tag))) - subtype-tag))) + (logandc2 supertype-tag (logior disjoint-tag subtype-tag))) + subtype-tag))) ;; A new type is to be registered, which is not simply a composition of ;; previous types. A new tag has to be created, and all supertypes are to be @@ -856,52 +856,52 @@ if not possible." (defun register-type (type in-our-family-p type-<=) (declare (si::c-local) (optimize (safety 0)) - (function in-our-family-p type-<=)) + (function in-our-family-p type-<=)) (or (find-registered-tag type) (multiple-value-bind (tag-super tag-sub) - (find-type-bounds type in-our-family-p type-<= nil) - (let ((tag (new-type-tag))) - (update-types (logandc2 tag-super tag-sub) tag) - (setf tag (logior tag tag-sub)) - (push-type type tag))))) + (find-type-bounds type in-our-family-p type-<= nil) + (let ((tag (new-type-tag))) + (update-types (logandc2 tag-super tag-sub) tag) + (setf tag (logior tag tag-sub)) + (push-type type tag))))) ;;---------------------------------------------------------------------- ;; MEMBER types. We register this object in a separate list, *MEMBER-TYPES*, ;; and tag all types to which it belongs. We need to treat three cases ;; separately -;; - Ordinary types, via simple-member-type, check the objects -;; against all pre-registered types, adding their tags. -;; - Ordinary numbers, are translated into intervals. -;; - Floating point zeros, have to be treated separately. This -;; is done by assigning a special tag to -0.0 and translating -;; (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0))) +;; - Ordinary types, via simple-member-type, check the objects +;; against all pre-registered types, adding their tags. +;; - Ordinary numbers, are translated into intervals. +;; - Floating point zeros, have to be treated separately. This +;; is done by assigning a special tag to -0.0 and translating +;; (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0))) ;; (defun register-member-type (object) ;(declare (si::c-local)) (let ((pos (assoc object *member-types*))) (cond ((and pos (cdr pos))) - ((not (realp object)) - (simple-member-type object)) - ((and (floatp object) (zerop object)) - #.(if (eql (- 0.0) 0.0) - '(number-member-type object) - '(if (minusp (float-sign object)) - (simple-member-type object) - (logandc2 (number-member-type object) - (register-member-type (- object)))))) - (t - (number-member-type object))))) + ((not (realp object)) + (simple-member-type object)) + ((and (floatp object) (zerop object)) + #.(if (eql (- 0.0) 0.0) + '(number-member-type object) + '(if (minusp (float-sign object)) + (simple-member-type object) + (logandc2 (number-member-type object) + (register-member-type (- object)))))) + (t + (number-member-type object))))) (defun simple-member-type (object) (declare (si::c-local) - (ext:assume-no-errors)) + (ext:assume-no-errors)) (let* ((tag (new-type-tag))) (maybe-save-types) (setq *member-types* (acons object tag *member-types*)) (dolist (i *elementary-types*) (let ((type (car i))) - (when (typep object type) - (setf (cdr i) (logior tag (cdr i)))))) + (when (typep object type) + (setf (cdr i) (logior tag (cdr i)))))) tag)) ;; We convert number into intervals, so that (AND INTEGER (NOT (EQL @@ -909,13 +909,13 @@ if not possible." ;; *)). (defun number-member-type (object) (let* ((base-type (if (integerp object) 'INTEGER (type-of object))) - (type (list base-type object object))) + (type (list base-type object object))) (or (find-registered-tag type) - (register-interval-type type)))) + (register-interval-type type)))) (defun push-type (type tag) (declare (si::c-local) - (ext:assume-no-errors)) + (ext:assume-no-errors)) (dolist (i *member-types*) (declare (cons i)) (when (typep (car i) type) @@ -929,7 +929,7 @@ if not possible." ;; (defun register-satisfies-type (type) (declare (si::c-local) - (ignore type)) + (ignore type)) (throw '+canonical-type-failure+ 'satisfies)) ;;---------------------------------------------------------------------- @@ -937,25 +937,25 @@ if not possible." ;; (defun register-class (class) (declare (si::c-local) - (notinline class-name)) + (notinline class-name)) (or (find-registered-tag class) ;; We do not need to register classes which belong to the core type ;; system of LISP (ARRAY, NUMBER, etc). (let* ((name (class-name class))) - (and name - (eq class (find-class name 'nil)) - (or (find-registered-tag name) - (find-built-in-tag name)))) + (and name + (eq class (find-class name 'nil)) + (or (find-registered-tag name) + (find-built-in-tag name)))) (and (not (clos::class-finalized-p class)) (throw '+canonical-type-failure+ nil)) (register-type class - #'(lambda (c) (or (si::instancep c) (symbolp c))) - #'(lambda (c1 c2) - (when (symbolp c1) - (setq c1 (find-class c1 nil))) - (when (symbolp c2) - (setq c2 (find-class c2 nil))) - (and c1 c2 (si::subclassp c1 c2)))))) + #'(lambda (c) (or (si::instancep c) (symbolp c))) + #'(lambda (c1 c2) + (when (symbolp c1) + (setq c1 (find-class c1 nil))) + (when (symbolp c2) + (setq c2 (find-class c2 nil))) + (and c1 c2 (si::subclassp c1 c2)))))) ;;---------------------------------------------------------------------- ;; ARRAY types. @@ -965,19 +965,19 @@ if not possible." (multiple-value-bind (array-class elt-type dimensions) (parse-array-type type) (cond ((eq elt-type '*) - (canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions)) - +upgraded-array-element-types+)))) - ((find-registered-tag (setq type (list array-class elt-type dimensions)))) - (t - #+nil - (when (and (consp dimensions) (> (count-if #'numberp dimensions) 1)) - (dotimes (i (length dimensions)) - (when (numberp (elt dimensions i)) - (let ((dims (make-list (length dimensions) :initial-element '*))) - (setf (elt dims i) (elt dimensions i)) - (register-type (list array-class elt-type dims) - #'array-type-p #'array-type-<=))))) - (register-type type #'array-type-p #'array-type-<=))))) + (canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions)) + +upgraded-array-element-types+)))) + ((find-registered-tag (setq type (list array-class elt-type dimensions)))) + (t + #+nil + (when (and (consp dimensions) (> (count-if #'numberp dimensions) 1)) + (dotimes (i (length dimensions)) + (when (numberp (elt dimensions i)) + (let ((dims (make-list (length dimensions) :initial-element '*))) + (setf (elt dims i) (elt dimensions i)) + (register-type (list array-class elt-type dims) + #'array-type-p #'array-type-<=))))) + (register-type type #'array-type-p #'array-type-<=))))) ;; ;; We look for the most specialized type which is capable of containing @@ -988,37 +988,37 @@ if not possible." (defun fast-upgraded-array-element-type (type) (declare (si::c-local)) (cond ((eql type '*) '*) - ((member type +upgraded-array-element-types+ :test #'eq) - type) - (t - (dolist (other-type +upgraded-array-element-types+ 'T) - (when (fast-subtypep type other-type) - (return other-type)))))) + ((member type +upgraded-array-element-types+ :test #'eq) + type) + (t + (dolist (other-type +upgraded-array-element-types+ 'T) + (when (fast-subtypep type other-type) + (return other-type)))))) ;; ;; This canonicalizes the array type into the form -;; ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)}) +;; ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)}) ;; ;; ELT-TYPE is the upgraded element type of the input. ;; (defun parse-array-type (input) (declare (si::c-local)) (let* ((type input) - (name (pop type)) - (elt-type (fast-upgraded-array-element-type (if type (pop type) '*))) - (dims (if type (pop type) '*))) + (name (pop type)) + (elt-type (fast-upgraded-array-element-type (if type (pop type) '*))) + (dims (if type (pop type) '*))) (when type (error "Wrong array type designator ~S." input)) (cond ((numberp dims) - (unless (< -1 dims array-rank-limit) - (error "Wrong rank size array type ~S." input)) - (setq dims (nthcdr (- array-rank-limit dims) - '#.(make-list array-rank-limit :initial-element '*)))) - ((consp dims) - (dolist (i dims) - (unless (or (eq i '*) - (and (integerp i) (< -1 i array-dimension-limit))) - (error "Wrong dimension size in array type ~S." input))))) + (unless (< -1 dims array-rank-limit) + (error "Wrong rank size array type ~S." input)) + (setq dims (nthcdr (- array-rank-limit dims) + '#.(make-list array-rank-limit :initial-element '*)))) + ((consp dims) + (dolist (i dims) + (unless (or (eq i '*) + (and (integerp i) (< -1 i array-dimension-limit))) + (error "Wrong dimension size in array type ~S." input))))) (values name elt-type dims))) ;; @@ -1027,20 +1027,20 @@ if not possible." ;; (defun array-type-<= (t1 t2) (unless (and (eq (first t1) (first t2)) - (eq (second t1) (second t2))) + (eq (second t1) (second t2))) (return-from array-type-<= nil)) (let ((dim (third t1)) - (pat (third t2))) + (pat (third t2))) (cond ((eq pat '*) t) - ((eq dim '*) nil) - (t (do ((a dim (cdr a)) - (b pat (cdr b))) - ((or (endp a) - (endp b) - (not (or (eq (car b) '*) - (eql (car b) (car a))))) - (and (null a) (null b))) - ))))) + ((eq dim '*) nil) + (t (do ((a dim (cdr a)) + (b pat (cdr b))) + ((or (endp a) + (endp b) + (not (or (eq (car b) '*) + (eql (car b) (car a))))) + (and (null a) (null b))) + ))))) (defun array-type-p (type) (and (consp type) @@ -1061,51 +1061,51 @@ if not possible." (setq type (list type b)) (or (find-registered-tag type #'equalp) (multiple-value-bind (tag-super tag-sub) - (find-type-bounds type - #'(lambda (other-type) - (and (consp other-type) - (null (cddr other-type)))) - #'(lambda (i1 i2) - (and (eq (first i1) (first i2)) - (bounds-<= (second i2) (second i1)))) - t) - (let ((tag (new-type-tag))) - (update-types (logandc2 tag-super tag-sub) tag) - (setq tag (logior tag tag-sub)) - (push-type type tag))))) + (find-type-bounds type + #'(lambda (other-type) + (and (consp other-type) + (null (cddr other-type)))) + #'(lambda (i1 i2) + (and (eq (first i1) (first i2)) + (bounds-<= (second i2) (second i1)))) + t) + (let ((tag (new-type-tag))) + (update-types (logandc2 tag-super tag-sub) tag) + (setq tag (logior tag tag-sub)) + (push-type type tag))))) (defun register-interval-type (interval) (declare (si::c-local)) (let* ((i interval) - (type (pop i)) - (low (if i (pop i) '*)) - (high (if i (pop i) '*)) - (tag-high (cond ((eq high '*) - 0) - ((eq type 'INTEGER) - (setq high (if (consp high) - (ceiling (first high)) - (floor (1+ high)))) - (register-elementary-interval type high)) - ((consp high) - (register-elementary-interval type (first high))) - (t - (register-elementary-interval type (list high))))) - (tag-low (register-elementary-interval type - (cond ((or (eq '* low) (not (eq type 'INTEGER)) (integerp low)) - low) - ((consp low) - (floor (1+ (first low)))) - (t - (ceiling low))))) - (tag (logandc2 tag-low tag-high))) + (type (pop i)) + (low (if i (pop i) '*)) + (high (if i (pop i) '*)) + (tag-high (cond ((eq high '*) + 0) + ((eq type 'INTEGER) + (setq high (if (consp high) + (ceiling (first high)) + (floor (1+ high)))) + (register-elementary-interval type high)) + ((consp high) + (register-elementary-interval type (first high))) + (t + (register-elementary-interval type (list high))))) + (tag-low (register-elementary-interval type + (cond ((or (eq '* low) (not (eq type 'INTEGER)) (integerp low)) + low) + ((consp low) + (floor (1+ (first low)))) + (t + (ceiling low))))) + (tag (logandc2 tag-low tag-high))) (unless (eq high '*) (push-type interval tag)) tag)) ;; All comparisons between intervals operations may be defined in terms of ;; -;; (BOUNDS-<= b1 b2) and (BOUNDS-< b1 b2) +;; (BOUNDS-<= b1 b2) and (BOUNDS-< b1 b2) ;; ;; The first one checks whether (REAL b2 *) is contained in (REAL b1 *). The ;; second one checks whether (REAL b2 *) is strictly contained in (REAL b1 *) @@ -1113,27 +1113,27 @@ if not possible." ;; (defun bounds-<= (b1 b2) (cond ((eq b1 '*) t) - ((eq b2 '*) nil) - ((consp b1) - (if (consp b2) - (<= (first b1) (first b2)) - (< (first b1) b2))) - ((consp b2) - (<= b1 (first b2))) - (t - (<= b1 b2)))) + ((eq b2 '*) nil) + ((consp b1) + (if (consp b2) + (<= (first b1) (first b2)) + (< (first b1) b2))) + ((consp b2) + (<= b1 (first b2))) + (t + (<= b1 b2)))) (defun bounds-< (b1 b2) (cond ((eq b1 '*) (not (eq b2 '*))) - ((eq b2 '*) nil) - ((consp b1) - (if (consp b2) - (< (first b1) (first b2)) - (< (first b1) b2))) - ((consp b2) - (<= b1 (first b2))) - (t - (< b1 b2)))) + ((eq b2 '*) nil) + ((consp b1) + (if (consp b2) + (< (first b1) (first b2)) + (< (first b1) b2))) + ((consp b2) + (<= b1 (first b2))) + (t + (< b1 b2)))) ;;---------------------------------------------------------------------- ;; COMPLEX types. We do not need to register anything, because all @@ -1149,7 +1149,7 @@ if not possible." (upgraded-complex-part-type real-type)) (or (find-registered-tag '(COMPLEX REAL)) (let ((tag (new-type-tag))) - (push-type '(COMPLEX REAL) tag))) + (push-type '(COMPLEX REAL) tag))) #+(or) (case real-type ((SINGLE-FLOAT DOUBLE-FLOAT INTEGER RATIO #+long-float LONG-FLOAT) @@ -1157,12 +1157,12 @@ if not possible." (push-type `(COMPLEX ,real-type) tag))) ((RATIONAL) (canonical-type '(OR (COMPLEX INTEGER) (COMPLEX RATIO)))) ((FLOAT) (canonical-type '(OR (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT) - #+long-float (COMPLEX LONG-FLOAT)))) + #+long-float (COMPLEX LONG-FLOAT)))) ((* NIL REAL) (canonical-type - '(OR (COMPLEX INTEGER) (COMPLEX RATIO) - (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT) - #+long-float (COMPLEX LONG-FLOAT) - ))) + '(OR (COMPLEX INTEGER) (COMPLEX RATIO) + (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT) + #+long-float (COMPLEX LONG-FLOAT) + ))) (otherwise (canonical-complex-type (upgraded-complex-part-type real-type))))) ;;---------------------------------------------------------------------- @@ -1176,13 +1176,13 @@ if not possible." #+(or) (canonical-type 'CONS) (let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type))) - (cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type)))) + (cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type)))) (cond ((or (zerop car-tag) (zerop cdr-tag)) - 0) - ((and (= car-tag -1) (= cdr-tag -1)) - (canonical-type 'CONS)) - (t - (throw '+canonical-type-failure+ 'CONS))))) + 0) + ((and (= car-tag -1) (= cdr-tag -1)) + (canonical-type 'CONS)) + (t + (throw '+canonical-type-failure+ 'CONS))))) ;;---------------------------------------------------------------------- ;; FIND-BUILT-IN-TAG @@ -1202,91 +1202,91 @@ if not possible." ;; #+ecl-min (defconstant +built-in-type-list+ - '((SYMBOL) - (KEYWORD NIL SYMBOL) - (PACKAGE) - (COMPILED-FUNCTION) - (FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION)) + '((SYMBOL) + (KEYWORD NIL SYMBOL) + (PACKAGE) + (COMPILED-FUNCTION) + (FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION)) - (INTEGER (INTEGER * *)) - (FIXNUM (INTEGER #.most-negative-fixnum #.most-positive-fixnum)) - (BIGNUM (OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *))) - (SINGLE-FLOAT (SINGLE-FLOAT * *)) - (DOUBLE-FLOAT (DOUBLE-FLOAT * *)) - #+long-float - (LONG-FLOAT (LONG-FLOAT * *)) - (RATIO (RATIO * *)) + (INTEGER (INTEGER * *)) + (FIXNUM (INTEGER #.most-negative-fixnum #.most-positive-fixnum)) + (BIGNUM (OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *))) + (SINGLE-FLOAT (SINGLE-FLOAT * *)) + (DOUBLE-FLOAT (DOUBLE-FLOAT * *)) + #+long-float + (LONG-FLOAT (LONG-FLOAT * *)) + (RATIO (RATIO * *)) - (RATIONAL (OR INTEGER RATIO)) - (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT + (RATIONAL (OR INTEGER RATIO)) + (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT #+long-float LONG-FLOAT)) - (REAL (OR INTEGER SINGLE-FLOAT DOUBLE-FLOAT - #+long-float LONG-FLOAT RATIO)) - (COMPLEX (COMPLEX REAL)) + (REAL (OR INTEGER SINGLE-FLOAT DOUBLE-FLOAT + #+long-float LONG-FLOAT RATIO)) + (COMPLEX (COMPLEX REAL)) - (NUMBER (OR REAL COMPLEX)) + (NUMBER (OR REAL COMPLEX)) - (CHARACTER) + (CHARACTER) #-unicode - (BASE-CHAR CHARACTER) + (BASE-CHAR CHARACTER) #+unicode - (BASE-CHAR NIL CHARACTER) - (STANDARD-CHAR NIL BASE-CHAR) + (BASE-CHAR NIL CHARACTER) + (STANDARD-CHAR NIL BASE-CHAR) - (CONS) - (NULL (MEMBER NIL)) - (LIST (OR CONS (MEMBER NIL))) + (CONS) + (NULL (MEMBER NIL)) + (LIST (OR CONS (MEMBER NIL))) - (ARRAY (ARRAY * *)) - (SIMPLE-ARRAY (SIMPLE-ARRAY * *)) - (SIMPLE-VECTOR (SIMPLE-ARRAY T (*))) - (SIMPLE-BIT-VECTOR (SIMPLE-ARRAY BIT (*))) - (VECTOR (ARRAY * (*))) - (STRING (ARRAY CHARACTER (*))) + (ARRAY (ARRAY * *)) + (SIMPLE-ARRAY (SIMPLE-ARRAY * *)) + (SIMPLE-VECTOR (SIMPLE-ARRAY T (*))) + (SIMPLE-BIT-VECTOR (SIMPLE-ARRAY BIT (*))) + (VECTOR (ARRAY * (*))) + (STRING (ARRAY CHARACTER (*))) #+unicode - (BASE-STRING (ARRAY BASE-CHAR (*))) - (SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*))) + (BASE-STRING (ARRAY BASE-CHAR (*))) + (SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*))) #+unicode - (SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*))) - (BIT-VECTOR (ARRAY BIT (*))) + (SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*))) + (BIT-VECTOR (ARRAY BIT (*))) - (SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*)))) + (SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*)))) - (HASH-TABLE) - (PATHNAME) - (LOGICAL-PATHNAME NIL PATHNAME) + (HASH-TABLE) + (PATHNAME) + (LOGICAL-PATHNAME NIL PATHNAME) - (BROADCAST-STREAM) - (CONCATENATED-STREAM) - (ECHO-STREAM) - (FILE-STREAM) - (STRING-STREAM) - (SYNONYM-STREAM) - (TWO-WAY-STREAM) - (EXT:SEQUENCE-STREAM) - (EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM + (BROADCAST-STREAM) + (CONCATENATED-STREAM) + (ECHO-STREAM) + (FILE-STREAM) + (STRING-STREAM) + (SYNONYM-STREAM) + (TWO-WAY-STREAM) + (EXT:SEQUENCE-STREAM) + (EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM EXT:SEQUENCE-STREAM #+clos-streams GRAY:FUNDAMENTAL-STREAM)) (STREAM EXT:ANSI-STREAM) - (READTABLE) - #+threads (MP::PROCESS) - #+threads (MP::LOCK) - #+threads (MP::RWLOCK) - #+threads (MP::CONDITION-VARIABLE) - #+threads (MP::SEMAPHORE) - #+threads (MP::BARRIER) - #+threads (MP::MAILBOX) - #+ffi (FOREIGN-DATA) - #+sse2 (EXT:SSE-PACK (OR EXT:INT-SSE-PACK - EXT:FLOAT-SSE-PACK - EXT:DOUBLE-SSE-PACK)) - #+sse2 (EXT:INT-SSE-PACK) - #+sse2 (EXT:FLOAT-SSE-PACK) - #+sse2 (EXT:DOUBLE-SSE-PACK) + (READTABLE) + #+threads (MP::PROCESS) + #+threads (MP::LOCK) + #+threads (MP::RWLOCK) + #+threads (MP::CONDITION-VARIABLE) + #+threads (MP::SEMAPHORE) + #+threads (MP::BARRIER) + #+threads (MP::MAILBOX) + #+ffi (FOREIGN-DATA) + #+sse2 (EXT:SSE-PACK (OR EXT:INT-SSE-PACK + EXT:FLOAT-SSE-PACK + EXT:DOUBLE-SSE-PACK)) + #+sse2 (EXT:INT-SSE-PACK) + #+sse2 (EXT:FLOAT-SSE-PACK) + #+sse2 (EXT:DOUBLE-SSE-PACK) (CODE-BLOCK) - )) + )) (defconstant +built-in-types+ (ext:hash-table-fill @@ -1297,29 +1297,29 @@ if not possible." (declare (si::c-local)) (let (record) (cond ((eq name T) - -1) - ((eq (setf record (gethash name +built-in-types+ name)) - name) - nil) - (t - (let* ((alias (pop record)) - tag) - (if alias - (setq tag (canonical-type alias)) - (let* ((strict-supertype (or (first record) 'T)) - (strict-supertype-tag (canonical-type strict-supertype))) - (setq tag (new-type-tag)) - (unless (eq strict-supertype 't) - (extend-type-tag tag strict-supertype-tag)))) - (push-type name tag)))))) + -1) + ((eq (setf record (gethash name +built-in-types+ name)) + name) + nil) + (t + (let* ((alias (pop record)) + tag) + (if alias + (setq tag (canonical-type alias)) + (let* ((strict-supertype (or (first record) 'T)) + (strict-supertype-tag (canonical-type strict-supertype))) + (setq tag (new-type-tag)) + (unless (eq strict-supertype 't) + (extend-type-tag tag strict-supertype-tag)))) + (push-type name tag)))))) (defun extend-type-tag (tag minimal-supertype-tag) (declare (si::c-local) - (ext:assume-no-errors)) + (ext:assume-no-errors)) (dolist (type *elementary-types*) (let ((other-tag (cdr type))) (when (zerop (logandc2 minimal-supertype-tag other-tag)) - (setf (cdr type) (logior tag other-tag)))))) + (setf (cdr type) (logior tag other-tag)))))) ;;---------------------------------------------------------------------- ;; CANONICALIZE (removed) @@ -1331,24 +1331,24 @@ if not possible." #+nil (defun canonicalize (type) (let ((*highest-type-tag* *highest-type-tag*) - (*save-types-database* t) - (*member-types* *member-types*) - (*elementary-types* *elementary-types*)) + (*save-types-database* t) + (*member-types* *member-types*) + (*elementary-types* *elementary-types*)) (let ((tag (canonical-type type)) - (out)) + (out)) (setq tag (canonical-type type)) ;;(print-types-database *elementary-types*) ;;(print-types-database *member-types*) (dolist (i *member-types*) - (unless (zerop (logand (cdr i) tag)) - (push (car i) out))) + (unless (zerop (logand (cdr i) tag)) + (push (car i) out))) (when out - (setq out `((MEMBER ,@out)))) + (setq out `((MEMBER ,@out)))) (dolist (i *elementary-types*) - (unless (zerop (logand (cdr i) tag)) - ;;(print (list tag (cdr i) (logand tag (cdr i)))) - (push (car i) out))) - (values tag `(OR ,@out))))) + (unless (zerop (logand (cdr i) tag)) + ;;(print (list tag (cdr i) (logand tag (cdr i)))) + (push (car i) out))) + (values tag `(OR ,@out))))) ;;---------------------------------------------------------------------- ;; (CANONICAL-TYPE TYPE) @@ -1361,64 +1361,64 @@ if not possible." (defun canonical-type (type) (declare (notinline clos::classp)) (cond ((find-registered-tag type)) - ((eq type 'T) -1) - ((eq type 'NIL) 0) + ((eq type 'T) -1) + ((eq type 'NIL) 0) ((symbolp type) - (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION))) - (cond (expander - (canonical-type (funcall expander))) - ((find-built-in-tag type)) - (t (let ((class (find-class type nil))) - (if class - (register-class class) - (throw '+canonical-type-failure+ nil))))))) - ((consp type) - (case (first type) - (AND (apply #'logand (mapcar #'canonical-type (rest type)))) - (OR (apply #'logior (mapcar #'canonical-type (rest type)))) - (NOT (lognot (canonical-type (second type)))) - ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) - (SATISFIES (register-satisfies-type type)) - ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) - (register-interval-type type)) - ((FLOAT) - (canonical-type `(OR (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((REAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type)) - (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((RATIONAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type))))) - (COMPLEX - (or (find-built-in-tag type) - (canonical-complex-type (second type)))) - (CONS (apply #'register-cons-type (rest type))) - (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) - (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) - ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) - ;;(FUNCTION (register-function-type type)) - ;;(VALUES (register-values-type type)) - (FUNCTION (canonical-type 'FUNCTION)) - (t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION))) - (if expander - (canonical-type (apply expander (rest type))) - (unless (assoc (first type) *elementary-types*) - (throw '+canonical-type-failure+ nil))))))) - ((clos::classp type) - (register-class type)) - ((and (fboundp 'function-type-p) (function-type-p type)) - (register-function-type type)) - ((and (fboundp 'values-type-p) (values-type-p type)) - (register-values-type type)) - (t - (error-type-specifier type)))) + (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION))) + (cond (expander + (canonical-type (funcall expander))) + ((find-built-in-tag type)) + (t (let ((class (find-class type nil))) + (if class + (register-class class) + (throw '+canonical-type-failure+ nil))))))) + ((consp type) + (case (first type) + (AND (apply #'logand (mapcar #'canonical-type (rest type)))) + (OR (apply #'logior (mapcar #'canonical-type (rest type)))) + (NOT (lognot (canonical-type (second type)))) + ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) + (SATISFIES (register-satisfies-type type)) + ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) + (register-interval-type type)) + ((FLOAT) + (canonical-type `(OR (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((REAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type)) + (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((RATIONAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type))))) + (COMPLEX + (or (find-built-in-tag type) + (canonical-complex-type (second type)))) + (CONS (apply #'register-cons-type (rest type))) + (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) + (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) + ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) + ;;(FUNCTION (register-function-type type)) + ;;(VALUES (register-values-type type)) + (FUNCTION (canonical-type 'FUNCTION)) + (t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION))) + (if expander + (canonical-type (apply expander (rest type))) + (unless (assoc (first type) *elementary-types*) + (throw '+canonical-type-failure+ nil))))))) + ((clos::classp type) + (register-class type)) + ((and (fboundp 'function-type-p) (function-type-p type)) + (register-function-type type)) + ((and (fboundp 'values-type-p) (values-type-p type)) + (register-values-type type)) + (t + (error-type-specifier type)))) (defun safe-canonical-type (type) (catch '+canonical-type-failure+ @@ -1429,19 +1429,19 @@ if not possible." (when (eq t1 t2) (return-from fast-subtypep (values t t))) (let* ((tag1 (safe-canonical-type t1)) - (tag2 (safe-canonical-type t2))) + (tag2 (safe-canonical-type t2))) (cond ((and (numberp tag1) (numberp tag2)) - (values (zerop (logandc2 (safe-canonical-type t1) - (safe-canonical-type t2))) - t)) - #+nil - ((null tag1) - (error "Unknown type specifier ~S." t1)) - #+nil - ((null tag2) - (error "Unknown type specifier ~S." t2)) - (t - (values nil nil))))) + (values (zerop (logandc2 (safe-canonical-type t1) + (safe-canonical-type t2))) + t)) + #+nil + ((null tag1) + (error "Unknown type specifier ~S." t1)) + #+nil + ((null tag2) + (error "Unknown type specifier ~S." t2)) + (t + (values nil nil))))) (defun subtypep (t1 t2 &optional env) (declare (ignore env)) @@ -1450,45 +1450,45 @@ if not possible." (return-from subtypep (values t t))) ;; Another easy case: types are classes. (when (and (instancep t1) (instancep t2) - (clos::classp t1) (clos::classp t2)) + (clos::classp t1) (clos::classp t2)) (return-from subtypep (values (subclassp t1 t2) t))) ;; Finally, cached results. (let* ((cache *subtypep-cache*) - (hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255))) - (elt (aref cache hash))) + (hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255))) + (elt (aref cache hash))) (when (and elt (eq (caar elt) t1) (eq (cdar elt) t2)) (setf elt (cdr elt)) (return-from subtypep (values (car elt) (cdr elt)))) (let* ((*highest-type-tag* *highest-type-tag*) - (*save-types-database* t) - (*member-types* *member-types*) - (*elementary-types* *elementary-types*)) + (*save-types-database* t) + (*member-types* *member-types*) + (*elementary-types* *elementary-types*)) (multiple-value-bind (test confident) - (fast-subtypep t1 t2) - (setf (aref cache hash) (cons (cons t1 t2) (cons test confident))) - (values test confident))))) + (fast-subtypep t1 t2) + (setf (aref cache hash) (cons (cons t1 t2) (cons test confident))) + (values test confident))))) (defun fast-type= (t1 t2) (declare (si::c-local)) (when (eq t1 t2) (return-from fast-type= (values t t))) (let* ((tag1 (safe-canonical-type t1)) - (tag2 (safe-canonical-type t2))) + (tag2 (safe-canonical-type t2))) (cond ((and (numberp tag1) (numberp tag2)) - (values (= (safe-canonical-type t1) (safe-canonical-type t2)) - t)) - #+nil - ((null tag1) - (error "Unknown type specifier ~S." t1)) - #+nil - ((null tag2) - (error "Unknown type specifier ~S." t2)) - (t - (values nil nil))))) + (values (= (safe-canonical-type t1) (safe-canonical-type t2)) + t)) + #+nil + ((null tag1) + (error "Unknown type specifier ~S." t1)) + #+nil + ((null tag2) + (error "Unknown type specifier ~S." t2)) + (t + (values nil nil))))) (defun type= (t1 t2) (let ((*highest-type-tag* *highest-type-tag*) - (*save-types-database* t) - (*member-types* *member-types*) - (*elementary-types* *elementary-types*)) + (*save-types-database* t) + (*member-types* *member-types*) + (*elementary-types* *elementary-types*)) (fast-type= t1 t2))) diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp index 1ec38e056..ca2024635 100644 --- a/src/lsp/seq.lsp +++ b/src/lsp/seq.lsp @@ -34,28 +34,28 @@ (defun error-sequence-type (type) (declare (si::c-local)) (error 'simple-type-error - :datum (vector) ;; Any sequence object will do, because it does not belong to TYPE - :expected-type type - :format-control "~S does not specify a sequence type" - :format-arguments (list type))) + :datum (vector) ;; Any sequence object will do, because it does not belong to TYPE + :expected-type type + :format-control "~S does not specify a sequence type" + :format-arguments (list type))) (defun error-sequence-length (object type size) (declare (si::c-local)) (error 'simple-type-error - :format-control - "Cannot create a sequence of size ~S which matches type ~S." - :format-arguments (list size type) - :expected-type type - :datum object)) + :format-control + "Cannot create a sequence of size ~S which matches type ~S." + :format-arguments (list size type) + :expected-type type + :datum object)) (defun closest-sequence-type (type) (let (elt-type length name args) (cond ((consp type) - (setq name (first type) args (cdr type))) - ((si::instancep type) - (setf name (class-name (truly-the class type)) args nil)) - (t - (setq name type args nil))) + (setq name (first type) args (cdr type))) + ((si::instancep type) + (setf name (class-name (truly-the class type)) args nil)) + (t + (setq name type args nil))) (case name ((LIST) ;; This is the only descriptor that does not match a real @@ -63,25 +63,25 @@ (setq elt-type 'LIST length '*)) ((VECTOR) (setq elt-type (if (endp args) 'T (first args)) - length (if (endp (rest args)) '* (second args)))) + length (if (endp (rest args)) '* (second args)))) ((SIMPLE-VECTOR) (setq elt-type 'T - length (if (endp args) '* (first args)))) + length (if (endp args) '* (first args)))) #-unicode ((STRING SIMPLE-STRING) (setq elt-type 'BASE-CHAR - length (if (endp args) '* (first args)))) + length (if (endp args) '* (first args)))) #+unicode ((BASE-STRING SIMPLE-BASE-STRING) (setq elt-type 'BASE-CHAR - length (if (endp args) '* (first args)))) + length (if (endp args) '* (first args)))) #+unicode ((STRING SIMPLE-STRING) (setq elt-type 'CHARACTER - length (if (endp args) '* (first args)))) + length (if (endp args) '* (first args)))) ((BIT-VECTOR SIMPLE-BIT-VECTOR) (setq elt-type 'BIT - length (if (endp args) '* (first args)))) + length (if (endp args) '* (first args)))) ((ARRAY SIMPLE-ARRAY) (let ((dimension-spec (second args))) (cond @@ -99,25 +99,25 @@ ;; type is *. Instead we just compare with some specialized ;; types and otherwise fail. (dolist (i '((NIL . NIL) - (LIST . LIST) + (LIST . LIST) (STRING . CHARACTER) . #.(mapcar #'(lambda (i) `((VECTOR ,i) . ,i)) +upgraded-array-element-types+)) - (if (subtypep type 'vector) - ;; Does this have to be a type-error? - ;; 17.3 for MAKE-SEQUENCE says it should be an error, - ;; but does not specialize what kind. - (error "Cannot find the element type in vector type ~S" type) - (error-sequence-type type))) - (when (subtypep type (car i)) - (setq elt-type (cdr i) length '*) - ;; The (NIL . NIL) case above - (unless elt-type - (error-sequence-type type)) - (return))))) + (if (subtypep type 'vector) + ;; Does this have to be a type-error? + ;; 17.3 for MAKE-SEQUENCE says it should be an error, + ;; but does not specialize what kind. + (error "Cannot find the element type in vector type ~S" type) + (error-sequence-type type))) + (when (subtypep type (car i)) + (setq elt-type (cdr i) length '*) + ;; The (NIL . NIL) case above + (unless elt-type + (error-sequence-type type)) + (return))))) (values elt-type length))) -(defun make-sequence (type size &key (initial-element nil iesp) &aux sequence) +(defun make-sequence (type size &key (initial-element nil iesp) &aux sequence) "Args: (type length &key initial-element) Creates and returns a sequence of the given TYPE and LENGTH. If INITIAL- ELEMENT is given, then it becomes the elements of the created sequence. The @@ -125,18 +125,18 @@ default value of INITIAL-ELEMENT depends on TYPE." (multiple-value-bind (element-type length) (closest-sequence-type type) (cond ((eq element-type 'LIST) - (setq sequence (make-list size :initial-element initial-element)) - (unless (subtypep 'LIST type) - (when (or (and (subtypep type 'NULL) (plusp size)) - (and (subtypep type 'CONS) (zerop size))) - (error-sequence-length (make-list size :initial-element initial-element) type 0)))) - (t - (setq sequence (sys:make-vector (if (eq element-type '*) T element-type) - size nil nil nil nil)) - (when iesp - (si::fill-array-with-elt sequence initial-element 0 nil)) - (unless (or (eql length '*) (eql length size)) - (error-sequence-length sequence type size)))) + (setq sequence (make-list size :initial-element initial-element)) + (unless (subtypep 'LIST type) + (when (or (and (subtypep type 'NULL) (plusp size)) + (and (subtypep type 'CONS) (zerop size))) + (error-sequence-length (make-list size :initial-element initial-element) type 0)))) + (t + (setq sequence (sys:make-vector (if (eq element-type '*) T element-type) + size nil nil nil nil)) + (when iesp + (si::fill-array-with-elt sequence initial-element 0 nil)) + (unless (or (eql length '*) (eql length size)) + (error-sequence-length sequence type size)))) sequence)) (defun make-seq-iterator (sequence &optional (start 0)) @@ -217,26 +217,26 @@ default value of INITIAL-ELEMENT depends on TYPE." (if (listp object) object (do ((it (make-seq-iterator object) (seq-iterator-next object it)) - (output nil)) - ((null it) (nreverse output)) - (push (seq-iterator-ref object it) output)))) + (output nil)) + ((null it) (nreverse output)) + (push (seq-iterator-ref object it) output)))) (defun coerce-to-vector (object elt-type length simple-array-p) (let ((output object)) (unless (and (vectorp object) (or (null simple-array-p) (simple-array-p object)) - (eq (array-element-type object) elt-type)) + (eq (array-element-type object) elt-type)) (let* ((final-length (if (eq length '*) (length object) length))) - (setf output (make-vector elt-type final-length nil nil nil 0)) - (do ((i (make-seq-iterator object) (seq-iterator-next output i)) - (j 0 (truly-the index (1+ j)))) - ((= j final-length) - (setf object output)) - (declare (index j)) - (setf (aref output j) (seq-iterator-ref object i))))) + (setf output (make-vector elt-type final-length nil nil nil 0)) + (do ((i (make-seq-iterator object) (seq-iterator-next output i)) + (j 0 (truly-the index (1+ j)))) + ((= j final-length) + (setf object output)) + (declare (index j)) + (setf (aref output j) (seq-iterator-ref object i))))) (unless (eq length '*) (unless (= length (length output)) - (check-type output `(vector ,elt-type (,length)) "coerced object"))) + (check-type output `(vector ,elt-type (,length)) "coerced object"))) output)) (defun concatenate (result-type &rest sequences) @@ -244,13 +244,13 @@ default value of INITIAL-ELEMENT depends on TYPE." Returns a new sequence of the specified type, consisting of all elements of SEQUENCEs." (do* ((length-list (mapcar #'length sequences) (rest length-list)) - (output (make-sequence result-type (apply #'+ length-list))) + (output (make-sequence result-type (apply #'+ length-list))) (sequences sequences (rest sequences)) (i (make-seq-iterator output))) ((null sequences) output) (do* ((s (first sequences)) - (j (make-seq-iterator s) (seq-iterator-next s j))) - ((null j)) + (j (make-seq-iterator s) (seq-iterator-next s j))) + ((null j)) (seq-iterator-set output i (seq-iterator-ref s j)) (setq i (seq-iterator-next output i))))) @@ -338,13 +338,13 @@ elements of the given sequences. The i-th element of RESULT-SEQUENCE is the outp of applying FUNCTION to the i-th element of each of the sequences. The map routine stops when it reaches the end of one of the given sequences." (let ((nel (apply #'min (if (vectorp result-sequence) - (array-dimension result-sequence 0) - (length result-sequence)) - (mapcar #'length sequences)))) + (array-dimension result-sequence 0) + (length result-sequence)) + (mapcar #'length sequences)))) (declare (fixnum nel)) ;; Set the fill pointer to the number of iterations (when (and (vectorp result-sequence) - (array-has-fill-pointer-p result-sequence)) + (array-has-fill-pointer-p result-sequence)) (setf (fill-pointer result-sequence) nel)) ;; Perform mapping (do ((ir (make-seq-iterator result-sequence) (seq-iterator-next result-sequence ir)) @@ -352,10 +352,10 @@ stops when it reaches the end of one of the given sequences." (val (make-sequence 'list (length sequences)))) ((null ir) result-sequence) (do ((i it (cdr i)) - (v val (cdr v)) + (v val (cdr v)) (s sequences (cdr s))) - ((null i)) - (unless (car i) (return-from map-into result-sequence)) - (rplaca v (seq-iterator-ref (car s) (car i))) - (rplaca i (seq-iterator-next (car s) (car i)))) + ((null i)) + (unless (car i) (return-from map-into result-sequence)) + (rplaca v (seq-iterator-ref (car s) (car i))) + (rplaca i (seq-iterator-next (car s) (car i)))) (seq-iterator-set result-sequence ir (apply function val))))) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index 63c58f254..ab6710608 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -30,7 +30,7 @@ (defun seqtype (sequence) (declare (si::c-local)) (cond ((listp sequence) 'list) - ((base-string-p sequence) 'base-string) + ((base-string-p sequence) 'base-string) ((stringp sequence) 'string) ((bit-vector-p sequence) 'bit-vector) ((vectorp sequence) (list 'vector (array-element-type sequence))) @@ -58,7 +58,7 @@ (defun unsafe-funcall1 (f x) (declare (function f) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (funcall f x)) (defun reduce (function sequence @@ -158,7 +158,7 @@ (declare (optimize (speed 3) (safety 0) (debug 0))) (with-start-end (start end in l) (with-count (%count count :output in) - (let* ((existing 0)) + (let* ((existing 0)) (declare (fixnum existing)) ;; If the OUT is empty that means we REMOVE and we have to ;; create the destination array. For that we first count how @@ -216,13 +216,13 @@ (declare (optimize (speed 3) (safety 0) (debug 0))) (with-start-end (start end sequence) (with-count (%count count :output sequence) - (let* ((output nil) - (index 0)) - (declare (fixnum index)) - (while (and sequence (< index start)) - (setf output (cons (cons-car sequence) output) - sequence (cons-cdr sequence) - index (1+ index))) + (let* ((output nil) + (index 0)) + (declare (fixnum index)) + (while (and sequence (< index start)) + (setf output (cons (cons-car sequence) output) + sequence (cons-cdr sequence) + index (1+ index))) (loop (unless (< index end) (return)) (let ((elt (cons-car sequence))) @@ -232,7 +232,7 @@ (return)) (push elt output)) (incf index))) - (nreconc output sequence)))))) + (nreconc output sequence)))))) (defun remove (which sequence &key test test-not (start 0) end from-end count key) @@ -251,28 +251,28 @@ (defun remove-if (predicate sequence &key (start 0) end from-end count key) (remove (si::coerce-to-function predicate) sequence - :start start :end end :from-end from-end :count count - :test #'unsafe-funcall1 :key key)) + :start start :end end :from-end from-end :count count + :test #'unsafe-funcall1 :key key)) (defun remove-if-not (predicate sequence &key (start 0) end from-end count key) (remove (si::coerce-to-function predicate) sequence - :start start :end end :from-end from-end :count count - :test-not #'unsafe-funcall1 :key key)) + :start start :end end :from-end from-end :count count + :test-not #'unsafe-funcall1 :key key)) (defun delete-list (which sequence start end count test test-not key) (with-tests (test test-not key) (declare (optimize (speed 3) (safety 0) (debug 0))) (with-start-end (start end sequence) (with-count (%count count :output sequence) - (let* ((splice (cons nil sequence)) + (let* ((splice (cons nil sequence)) (output splice) - (index 0)) - (declare (fixnum index) + (index 0)) + (declare (fixnum index) (cons splice)) - (while (and sequence (< index start)) - (setf sequence (cons-cdr sequence) - splice (cons-cdr splice) - index (1+ index))) + (while (and sequence (< index start)) + (setf sequence (cons-cdr sequence) + splice (cons-cdr splice) + index (1+ index))) (loop (unless (< index end) (return)) @@ -313,61 +313,61 @@ (defun delete-if (predicate sequence &key (start 0) end from-end count key) (delete (si::coerce-to-function predicate) sequence - :start start :end end :from-end from-end :count count - :test #'unsafe-funcall1 :key key)) + :start start :end end :from-end from-end :count count + :test #'unsafe-funcall1 :key key)) (defun delete-if-not (predicate sequence &key (start 0) end from-end count key) (delete (si::coerce-to-function predicate) sequence - :start start :end end :from-end from-end :count count - :test-not #'unsafe-funcall1 :key key)) + :start start :end end :from-end from-end :count count + :test-not #'unsafe-funcall1 :key key)) (defun count (item sequence &key test test-not from-end (start 0) end key) (with-tests (test test-not key) (declare (optimize (speed 3) (safety 0) (debug 0))) (with-start-end (start end sequence l) (let ((counter 0)) - (declare (fixnum counter)) - (if from-end - (if (listp sequence) + (declare (fixnum counter)) + (if from-end + (if (listp sequence) (count item (reverse sequence) :start (- l end) :end (- l start) :test test :test-not test-not :key key) - (do-vector (elt sequence start end :from-end t + (do-vector (elt sequence start end :from-end t :output counter) - (when (compare item (key elt)) - (incf counter)))) - (do-sequence (elt sequence start end :specialize t + (when (compare item (key elt)) + (incf counter)))) + (do-sequence (elt sequence start end :specialize t :output counter) - (when (compare item (key elt)) - (incf counter)))))))) + (when (compare item (key elt)) + (incf counter)))))))) (defun count-if (predicate sequence &key from-end (start 0) end key) (count (si::coerce-to-function predicate) sequence - :from-end from-end :start start :end end - :test #'unsafe-funcall1 :key key)) + :from-end from-end :start start :end end + :test #'unsafe-funcall1 :key key)) (defun count-if-not (predicate sequence &key from-end (start 0) end key) (count (si::coerce-to-function predicate) - sequence :from-end from-end :start start :end end - :test-not #'unsafe-funcall1 :key key)) + sequence :from-end from-end :start start :end end + :test-not #'unsafe-funcall1 :key key)) (defun substitute (new old sequence &key test test-not (start 0) end from-end count key) (nsubstitute new old (copy-seq sequence) :start start :end end :from-end from-end - :count count :key key :test test :test-not test-not)) + :count count :key key :test test :test-not test-not)) (defun substitute-if (new predicate sequence - &key (start 0) end from-end count key) + &key (start 0) end from-end count key) (nsubstitute new (si::coerce-to-function predicate) (copy-seq sequence) - :key key :test #'unsafe-funcall1 + :key key :test #'unsafe-funcall1 :start start :end end :from-end from-end :count count :key key)) (defun substitute-if-not (new predicate sequence - &key (start 0) end from-end count key) + &key (start 0) end from-end count key) (nsubstitute new (si::coerce-to-function predicate) (copy-seq sequence) - :key key :test-not #'unsafe-funcall1 + :key key :test-not #'unsafe-funcall1 :start start :end end :from-end from-end :count count :key key)) @@ -377,9 +377,9 @@ (declare (optimize (speed 3) (safety 0) (debug 0))) (with-start-end (start end sequence l) (with-count (%count count :output sequence) - ;; FIXME! This could be simplified to (AND FROM-END COUNT) - ;; but the ANSI test suite complains because it expects always - ;; a from-end inspection order! + ;; FIXME! This could be simplified to (AND FROM-END COUNT) + ;; but the ANSI test suite complains because it expects always + ;; a from-end inspection order! (if from-end (if (listp sequence) (nreverse @@ -403,14 +403,14 @@ (defun nsubstitute-if (new predicate sequence &key (start 0) end from-end count key) (nsubstitute new (si::coerce-to-function predicate) sequence - :key key :test #'unsafe-funcall1 + :key key :test #'unsafe-funcall1 :start start :end end :from-end from-end :count count :key key)) (defun nsubstitute-if-not (new predicate sequence &key (start 0) end from-end count key) (nsubstitute new (si::coerce-to-function predicate) sequence - :key key :test-not #'unsafe-funcall1 + :key key :test-not #'unsafe-funcall1 :start start :end end :from-end from-end :count count :key key)) @@ -430,13 +430,13 @@ (defun find-if (predicate sequence &key from-end (start 0) end key) (find (si::coerce-to-function predicate) sequence - :from-end from-end :start start :end end - :test #'unsafe-funcall1 :key key)) + :from-end from-end :start start :end end + :test #'unsafe-funcall1 :key key)) (defun find-if-not (predicate sequence &key from-end (start 0) end key) (find (si::coerce-to-function predicate) sequence - :from-end from-end :start start :end end - :test-not #'unsafe-funcall1 :key key)) + :from-end from-end :start start :end end + :test-not #'unsafe-funcall1 :key key)) (defun position (item sequence &key test test-not from-end (start 0) end key) @@ -593,9 +593,9 @@ Returns a copy of SEQUENCE without duplicated elements." (setf index (1+ index)))))))) (defun delete-duplicates (sequence - &key test test-not from-end (start 0) end key) + &key test test-not from-end (start 0) end key) "Args: (sequence &key key - (test '#'eql) test-not + (test '#'eql) test-not (start 0) (end (length sequence)) (from-end nil)) Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed." (cond ((listp sequence) @@ -621,9 +621,9 @@ Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed." v)))) (defun mismatch (sequence1 sequence2 - &key from-end test test-not key - (start1 0) (start2 0) - end1 end2) + &key from-end test test-not key + (start1 0) (start2 0) + end1 end2) "Args: (sequence1 sequence2 &key key (test '#'eql) test-not (start1 0) (end1 (length sequence1)) @@ -637,28 +637,28 @@ element that does not match." (with-start-end (start2 end2 sequence2) (with-tests (test test-not key) (if (not from-end) - (do ((i1 start1 (1+ i1)) - (i2 start2 (1+ i2))) - ((or (>= i1 end1) (>= i2 end2)) - (if (and (>= i1 end1) (>= i2 end2)) nil i1)) - (declare (fixnum i1 i2)) - (unless (compare (key (elt sequence1 i1)) - (key (elt sequence2 i2))) - (return i1))) - (do ((i1 (1- end1) (1- i1)) - (i2 (1- end2) (1- i2))) - ((or (< i1 start1) (< i2 start2)) - (if (and (< i1 start1) (< i2 start2)) nil (1+ i1))) - (declare (fixnum i1 i2)) - (unless (compare (key (elt sequence1 i1)) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (>= i1 end1) (>= i2 end2)) + (if (and (>= i1 end1) (>= i2 end2)) nil i1)) + (declare (fixnum i1 i2)) + (unless (compare (key (elt sequence1 i1)) (key (elt sequence2 i2))) - (return (1+ i1))))))))) + (return i1))) + (do ((i1 (1- end1) (1- i1)) + (i2 (1- end2) (1- i2))) + ((or (< i1 start1) (< i2 start2)) + (if (and (< i1 start1) (< i2 start2)) nil (1+ i1))) + (declare (fixnum i1 i2)) + (unless (compare (key (elt sequence1 i1)) + (key (elt sequence2 i2))) + (return (1+ i1))))))))) (defun search (sequence1 sequence2 &key from-end test test-not key - (start1 0) (start2 0) - end1 end2) + (start1 0) (start2 0) + end1 end2) "Args: (sequence1 sequence2 &key key (test '#'eql) test-not (start1 0) (end1 (length sequence1)) @@ -763,11 +763,11 @@ subsequence is found. Returns NIL otherwise." Destructively sorts SEQUENCE and returns the result. TEST should return non- NIL if its first argument is to precede its second argument. The order of two elements X and Y is arbitrary if both - (FUNCALL TEST X Y) - (FUNCALL TEST Y X) + (FUNCALL TEST X Y) + (FUNCALL TEST Y X) evaluates to NIL. See STABLE-SORT." (setf key (if key (si::coerce-to-function key) #'identity) - predicate (si::coerce-to-function predicate)) + predicate (si::coerce-to-function predicate)) (if (listp sequence) (list-merge-sort sequence predicate key) (quick-sort sequence 0 (truly-the fixnum (1- (length sequence))) predicate key))) @@ -775,38 +775,38 @@ evaluates to NIL. See STABLE-SORT." (defun list-merge-sort (l predicate key) (declare (si::c-local) - (optimize (safety 0) (speed 3)) - (function predicate key)) + (optimize (safety 0) (speed 3)) + (function predicate key)) (prog ((i 0) left right l0 l1 key-left key-right) (declare (fixnum i)) (setq i (length l)) (cond ((< i 2) (return l)) - ((= i 2) - (setq key-left (funcall key (car l))) - (setq key-right (funcall key (cadr l))) - (cond ((funcall predicate key-left key-right) (return l)) - ((funcall predicate key-right key-left) - (return (nreverse l))) - (t (return l))))) + ((= i 2) + (setq key-left (funcall key (car l))) + (setq key-right (funcall key (cadr l))) + (cond ((funcall predicate key-left key-right) (return l)) + ((funcall predicate key-right key-left) + (return (nreverse l))) + (t (return l))))) (setq i (floor i 2)) (do ((j 1 (1+ j)) (l1 l (cdr l1))) - ((>= j i) - (setq left l) - (setq right (cdr l1)) - (rplacd l1 nil)) + ((>= j i) + (setq left l) + (setq right (cdr l1)) + (rplacd l1 nil)) (declare (fixnum j))) (setq left (list-merge-sort left predicate key)) (setq right (list-merge-sort right predicate key)) (cond ((endp left) (return right)) - ((endp right) (return left))) + ((endp right) (return left))) (setq l0 (cons nil nil)) (setq l1 l0) (setq key-left (funcall key (car left))) (setq key-right (funcall key (car right))) loop (cond ((funcall predicate key-left key-right) (go left)) - ((funcall predicate key-right key-left) (go right)) - (t (go left))) + ((funcall predicate key-right key-left) (go right)) + (t (go left))) left (rplacd l1 left) (setq l1 (cdr l1)) @@ -829,43 +829,43 @@ evaluates to NIL. See STABLE-SORT." (defun quick-sort (seq start end pred key) (declare (fixnum start end) - (function pred key) - (optimize (safety 0)) - (si::c-local)) + (function pred key) + (optimize (safety 0)) + (si::c-local)) (if (< start end) (let* ((j (1+ end))) - (declare (fixnum j)) - (let* ((i start) - (l (- end start)) - (l-half (ash l -1)) - (p (+ start l-half)) - (d (elt seq p)) - (kd (funcall key d))) - (declare (fixnum i p l l-half)) - (rotatef (elt seq p) (elt seq start)) - (block outer-loop - (loop - (loop - (unless (> (decf j) i) (return-from outer-loop)) - (when (funcall pred - (funcall key (elt seq j)) kd) - (return))) - (loop - (unless (< (incf i) j) (return-from outer-loop)) - (unless (funcall pred - (funcall key (elt seq i)) kd) - (return))) - (rotatef (elt seq i) (elt seq j)))) - (setf (elt seq start) (elt seq j) - (elt seq j) d)) - (if (< (truly-the fixnum (- j start)) - (truly-the fixnum (- end j))) - (progn - (quick-sort seq start (1- j) pred key) - (quick-sort seq (1+ j) end pred key)) - (progn - (quick-sort seq (1+ j) end pred key) - (quick-sort seq start (1- j) pred key)))) + (declare (fixnum j)) + (let* ((i start) + (l (- end start)) + (l-half (ash l -1)) + (p (+ start l-half)) + (d (elt seq p)) + (kd (funcall key d))) + (declare (fixnum i p l l-half)) + (rotatef (elt seq p) (elt seq start)) + (block outer-loop + (loop + (loop + (unless (> (decf j) i) (return-from outer-loop)) + (when (funcall pred + (funcall key (elt seq j)) kd) + (return))) + (loop + (unless (< (incf i) j) (return-from outer-loop)) + (unless (funcall pred + (funcall key (elt seq i)) kd) + (return))) + (rotatef (elt seq i) (elt seq j)))) + (setf (elt seq start) (elt seq j) + (elt seq j) d)) + (if (< (truly-the fixnum (- j start)) + (truly-the fixnum (- end j))) + (progn + (quick-sort seq start (1- j) pred key) + (quick-sort seq (1+ j) end pred key)) + (progn + (quick-sort seq (1+ j) end pred key) + (quick-sort seq start (1- j) pred key)))) seq)) @@ -874,12 +874,12 @@ evaluates to NIL. See STABLE-SORT." Destructively sorts SEQUENCE and returns the result. TEST should return non- NIL if its first argument is to precede its second argument. For two elements X and Y, if both - (FUNCALL TEST X Y) - (FUNCALL TEST Y X) + (FUNCALL TEST X Y) + (FUNCALL TEST Y X) evaluates to NIL, then the order of X and Y are the same as in the original SEQUENCE. See SORT." (setf key (if key (si::coerce-to-function key) #'identity) - predicate (si::coerce-to-function predicate)) + predicate (si::coerce-to-function predicate)) (if (listp sequence) (list-merge-sort sequence predicate key) (if (bit-vector-p sequence) @@ -891,7 +891,7 @@ SEQUENCE. See SORT." (defun merge (result-type sequence1 sequence2 predicate &key key - &aux (l1 (length sequence1)) (l2 (length sequence2))) + &aux (l1 (length sequence1)) (l2 (length sequence2))) "Args: (type sequence1 sequence2 test &key key) Merges two sequences in the way specified by TEST and returns the result as a sequence of TYPE. Both SEQUENCEs may be destroyed. If both SEQUENCE1 and @@ -901,31 +901,31 @@ the sense of TEST." (with-key (key) (with-predicate (predicate) (do* ((size (truly-the fixnum (+ l1 l2))) - (j 0 (1+ j)) - (newseq (make-sequence result-type size)) - (i1 0) - (i2 0)) - ((= j size) newseq) - (declare (fixnum size j i1 i2)) - (if (>= i1 l1) - (setf (elt newseq j) (elt sequence2 i2) - i2 (1+ i2)) - (let ((v1 (elt sequence1 i1))) - (if (>= i2 l2) - (setf (elt newseq j) v1 - i1 (1+ i1)) - (let* ((v2 (elt sequence2 i2)) - (k2 (key v2)) - (k1 (key v1))) - (cond ((predicate k1 k2) - (setf (elt newseq j) v1 - i1 (1+ i1))) - ((predicate k2 k1) - (setf (elt newseq j) v2 - i2 (1+ i2))) - (t - (setf (elt newseq j) v1 - i1 (1+ i1)))))))))))) + (j 0 (1+ j)) + (newseq (make-sequence result-type size)) + (i1 0) + (i2 0)) + ((= j size) newseq) + (declare (fixnum size j i1 i2)) + (if (>= i1 l1) + (setf (elt newseq j) (elt sequence2 i2) + i2 (1+ i2)) + (let ((v1 (elt sequence1 i1))) + (if (>= i2 l2) + (setf (elt newseq j) v1 + i1 (1+ i1)) + (let* ((v2 (elt sequence2 i2)) + (k2 (key v2)) + (k1 (key v1))) + (cond ((predicate k1 k2) + (setf (elt newseq j) v1 + i1 (1+ i1))) + ((predicate k2 k1) + (setf (elt newseq j) v2 + i2 (1+ i2))) + (t + (setf (elt newseq j) v1 + i1 (1+ i1)))))))))))) (defun complement (f) "Args: (f) diff --git a/src/lsp/seqmacros.lsp b/src/lsp/seqmacros.lsp index 8cad46d0d..747318a83 100644 --- a/src/lsp/seqmacros.lsp +++ b/src/lsp/seqmacros.lsp @@ -20,51 +20,51 @@ `(let ((,count (sequence-count ,value))) (declare (fixnum ,count)) ,(if output-p - `(if (plusp ,count) - ,body - ,output) - body))) + `(if (plusp ,count) + ,body + ,output) + body))) (defmacro with-predicate ((predicate) &body body) `(let ((,predicate (si::coerce-to-function ,predicate))) (declare (function ,predicate)) (macrolet ((,predicate (&rest args) - `(locally (declare (optimize (safety 0) (speed 3))) - (funcall ,',predicate ,@args)))) + `(locally (declare (optimize (safety 0) (speed 3))) + (funcall ,',predicate ,@args)))) ,@body))) (defmacro with-key ((akey) &body body) `(let ((,akey (if ,akey (si::coerce-to-function ,akey) #'identity))) (declare (function ,akey)) (macrolet ((,akey (value) - `(locally (declare (optimize (safety 0) (speed 3))) - (funcall ,',akey ,value)))) + `(locally (declare (optimize (safety 0) (speed 3))) + (funcall ,',akey ,value)))) ,@body))) (defmacro with-tests (&whole whole (test test-not &optional key) &body body) (ext::with-unique-names (%test %test-not %test-fn) `(let* ((,%test ,test) - (,%test-not ,test-not) - (,%test-fn (if ,%test - (progn (when ,%test-not (test-error)) - (si::coerce-to-function ,%test)) - (if ,%test-not - (si::coerce-to-function ,%test-not) - #'eql)))) + (,%test-not ,test-not) + (,%test-fn (if ,%test + (progn (when ,%test-not (test-error)) + (si::coerce-to-function ,%test)) + (if ,%test-not + (si::coerce-to-function ,%test-not) + #'eql)))) (declare (function ,%test-fn)) (macrolet ((compare (v1 v2) - `(locally (declare (optimize (safety 0) (speed 3))) - (if ,',%test-not - (not (funcall ,',%test-fn ,v1 ,v2)) - (funcall ,',%test-fn ,v1 ,v2))))) - ,@(if key `((with-key (,key) ,@body)) body))))) + `(locally (declare (optimize (safety 0) (speed 3))) + (if ,',%test-not + (not (funcall ,',%test-fn ,v1 ,v2)) + (funcall ,',%test-fn ,v1 ,v2))))) + ,@(if key `((with-key (,key) ,@body)) body))))) (defmacro with-start-end ((start end seq &optional (length (gensym) length-p)) &body body) `(multiple-value-bind (,start ,end ,length) (sequence-start-end 'subseq ,seq ,start ,end) (declare (fixnum ,start ,end ,length) - ,@(unless length-p `((ignorable ,length)))) + ,@(unless length-p `((ignorable ,length)))) ,@body)) (defmacro reckless (&body body) @@ -81,22 +81,22 @@ ,value)))) ,@body)))) (if from-end - `(do* ((,%vector ,vector) - (,index ,end) - (,%count ,start)) - ((= ,index ,%count) ,output) - (declare (fixnum ,index ,%count) - (vector ,%vector)) - (let ((,elt (reckless (aref ,%vector (setf ,index (1- ,index)))))) - ,@body)) - `(do* ((,%vector ,vector) - (,index ,start (1+ ,index)) - (,%count ,end)) - ((= ,index ,%count) ,output) - (declare (fixnum ,index ,%count) - (vector ,%vector)) - (let ((,elt (reckless (aref ,%vector ,index)))) - ,@body))))) + `(do* ((,%vector ,vector) + (,index ,end) + (,%count ,start)) + ((= ,index ,%count) ,output) + (declare (fixnum ,index ,%count) + (vector ,%vector)) + (let ((,elt (reckless (aref ,%vector (setf ,index (1- ,index)))))) + ,@body)) + `(do* ((,%vector ,vector) + (,index ,start (1+ ,index)) + (,%count ,end)) + ((= ,index ,%count) ,output) + (declare (fixnum ,index ,%count) + (vector ,%vector)) + (let ((,elt (reckless (aref ,%vector ,index)))) + ,@body))))) (defmacro do-sublist ((elt list start end &key output setter (index (gensym))) @@ -107,35 +107,35 @@ `(reckless (rplaca ,',%sublist ,value)))) ,@body)))) `(do* ((,index ,start (1+ ,index)) - (,%sublist (nthcdr ,index ,list) (cdr ,%sublist)) - (,%count (- ,end ,index) (1- ,%count))) - ((<= ,%count 0) ,output) + (,%sublist (nthcdr ,index ,list) (cdr ,%sublist)) + (,%count (- ,end ,index) (1- ,%count))) + ((<= ,%count 0) ,output) (declare (fixnum ,index ,%count) - (cons ,%sublist)) + (cons ,%sublist)) (let ((,elt (car ,%sublist))) - ,@body)))) + ,@body)))) (defmacro do-sequence ((elt sequence start end &rest args &key setter index output specialize) - &body body) + &body body) (if specialize (with-unique-names (%sequence) (setf args (copy-list args)) (remf args :specialize) (setf args (list* elt %sequence start end args)) - `(let ((,%sequence ,sequence)) - (if (listp ,%sequence) - (do-sublist ,args ,@body) - (do-vector ,args ,@body)))) + `(let ((,%sequence ,sequence)) + (if (listp ,%sequence) + (do-sublist ,args ,@body) + (do-vector ,args ,@body)))) (with-unique-names (%sequence %start %i %count) - `(do* ((,%sequence ,sequence) - (,index ,start (1+ ,index)) - (,%i (make-seq-iterator ,%sequence ,index) - (seq-iterator-next ,%sequence ,%i)) - (,%count (- ,end ,start) (1- ,%count))) - ((or (null ,%i) (not (plusp ,%count))) ,output) - (let ((,elt (seq-iterator-ref ,%sequence ,%i))) - ,@body))))) + `(do* ((,%sequence ,sequence) + (,index ,start (1+ ,index)) + (,%i (make-seq-iterator ,%sequence ,index) + (seq-iterator-next ,%sequence ,%i)) + (,%count (- ,end ,start) (1- ,%count))) + ((or (null ,%i) (not (plusp ,%count))) ,output) + (let ((,elt (seq-iterator-ref ,%sequence ,%i))) + ,@body))))) (defmacro do-sequences ((elt-list seq-list &key output) &body body) (with-unique-names (%iterators %sequences) diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index ac0ba016e..4a5627be3 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -24,23 +24,23 @@ (defun do-setf-method-expansion (name lambda args) (declare (si::c-local)) (let* ((vars '()) - (inits '()) - (all '())) + (inits '()) + (all '())) (dolist (item args) (unless (or (fixnump item) (keywordp item)) - (push item inits) - (setq item (gensym)) - (push item vars)) + (push item inits) + (setq item (gensym)) + (push item vars)) (push item all)) (let* ((store (gensym)) - (all (nreverse all))) + (all (nreverse all))) (values (nreverse vars) - (nreverse inits) - (list store) - (if lambda - (apply lambda store all) - `(funcall #'(setf ,name) ,store ,@all)) - (cons name all))))) + (nreverse inits) + (list store) + (if lambda + (apply lambda store all) + `(funcall #'(setf ,name) ,store ,@all)) + (cons name all))))) (defun setf-method-wrapper (name setf-lambda) (declare (si::c-local)) @@ -61,27 +61,27 @@ ;;; DEFSETF macro. (defmacro defsetf (&whole whole access-fn &rest rest) "Syntax: (defsetf symbol update-fun [doc]) - or - (defsetf symbol lambda-list (store-var) {decl | doc}* {form}*) + or + (defsetf symbol lambda-list (store-var) {decl | doc}* {form}*) Defines an expansion - (setf (SYMBOL arg1 ... argn) value) - => (UPDATE-FUN arg1 ... argn value) - or - (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest) + (setf (SYMBOL arg1 ... argn) value) + => (UPDATE-FUN arg1 ... argn value) + or + (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest) where REST is the value of the last FORM with parameters in LAMBDA-LIST bound to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0. The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation 'SYMBOL 'setf)." (let (function documentation) (if (and (car rest) (or (symbolp (car rest)) (functionp (car rest)))) - (setq function `',(car rest) - documentation (cadr rest)) - (let* ((store (second rest)) - (args (first rest)) - (body (cddr rest))) - (setq documentation (find-documentation body) - function `#'(lambda-block ,access-fn (,@store ,@args) ,@body)) - (check-stores-number 'DEFSETF store 1))) + (setq function `',(car rest) + documentation (cadr rest)) + (let* ((store (second rest)) + (args (first rest)) + (body (cddr rest))) + (setq documentation (find-documentation body) + function `#'(lambda-block ,access-fn (,@store ,@args) ,@body)) + (check-stores-number 'DEFSETF store 1))) `(eval-when (compile load eval) ,(ext:register-with-pde whole `(do-defsetf ',access-fn ,function)) ,@(si::expand-set-documentation access-fn 'setf documentation) @@ -97,31 +97,31 @@ When a form (setf (SYMBOL arg1 ... argn) value-form) is evaluated, the FORMs given in the DEFINE-SETF-EXPANDER are evaluated in order with the parameters in DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. The last FORM must return five values - (var1 ... vark) - (form1 ... formk) - (value-var) - storing-form - access-form + (var1 ... vark) + (form1 ... formk) + (value-var) + storing-form + access-form in order. These values are collectively called the five gangs of the generalized variable (SYMBOL arg1 ... argn). The whole SETF form is then expanded into - (let* ((var1 from1) ... (vark formk) - (value-var value-form)) - storing-form) + (let* ((var1 from1) ... (vark formk) + (value-var value-form)) + storing-form) The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'SETF)." (let ((env (member '&environment args :test #'eq))) (if env - (setq args (cons (second env) - (nconc (ldiff args env) (cddr env)))) - (progn - (setq env (gensym)) - (setq args (cons env args)) - (push `(declare (ignore ,env)) body)))) + (setq args (cons (second env) + (nconc (ldiff args env) (cddr env)))) + (progn + (setq env (gensym)) + (setq args (cons env args)) + (push `(declare (ignore ,env)) body)))) `(eval-when (compile load eval) (do-define-setf-method ',access-fn #'(ext::lambda-block ,access-fn ,args ,@body)) ,@(si::expand-set-documentation access-fn 'setf - (find-documentation body)) + (find-documentation body)) ',access-fn)) @@ -135,18 +135,18 @@ Does not check if the third gang is a single-element list." ;; Note that macroexpansion of SETF arguments can only be done via ;; MACROEXPAND-1 [ANSI 5.1.2.7] (cond ((symbolp form) - (if (and (setq f (macroexpand-1 form env)) (not (equal f form))) - (get-setf-expansion f env) - (let ((store (gensym))) - (values nil nil (list store) `(setq ,form ,store) form)))) - ((or (not (consp form)) (not (symbolp (car form)))) - (error "Cannot get the setf-method of ~S." form)) - ((setq f (get-sysprop (car form) 'SETF-METHOD)) - (apply f env (cdr form))) - ((and (setq f (macroexpand-1 form env)) (not (equal f form))) - (get-setf-expansion f env)) - (t - (do-setf-method-expansion (car form) nil (cdr form))))) + (if (and (setq f (macroexpand-1 form env)) (not (equal f form))) + (get-setf-expansion f env) + (let ((store (gensym))) + (values nil nil (list store) `(setq ,form ,store) form)))) + ((or (not (consp form)) (not (symbolp (car form)))) + (error "Cannot get the setf-method of ~S." form)) + ((setq f (get-sysprop (car form) 'SETF-METHOD)) + (apply f env (cdr form))) + ((and (setq f (macroexpand-1 form env)) (not (equal f form))) + (get-setf-expansion f env)) + (t + (do-setf-method-expansion (car form) nil (cdr form))))) ;;;; SETF definitions. @@ -233,7 +233,7 @@ Does not check if the third gang is a single-element list." `(getf ,access-form ,itemp ,default))))) (defsetf subseq (sequence1 start1 &optional end1) - (sequence2) + (sequence2) `(PROGN (REPLACE ,sequence1 ,sequence2 :START1 ,start1 :END1 ,end1) ,sequence2)) @@ -247,15 +247,15 @@ Does not check if the third gang is a single-element list." #| (define-setf-expander apply (&environment env fn &rest rest) (unless (and (consp fn) (eq (car fn) 'FUNCTION) (symbolp (cadr fn)) - (null (cddr fn))) - (error "Can't get the setf-method of ~S." fn)) + (null (cddr fn))) + (error "Can't get the setf-method of ~S." fn)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion (cons (cadr fn) rest) env) (unless (eq (car (last store-form)) (car (last vars))) (error "Can't get the setf-method of ~S." fn)) (values vars vals stores - `(apply #',(car store-form) ,@(cdr store-form)) - `(apply #',(cadr fn) ,@(cdr access-form))))) + `(apply #',(car store-form) ,@(cdr store-form)) + `(apply #',(cadr fn) ,@(cdr access-form))))) |# (define-setf-expander apply (&environment env fn &rest rest) @@ -283,31 +283,31 @@ Does not check if the third gang is a single-element list." (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (let* ((btemp (gensym)) - (store (gensym)) - (stemp (first stores))) + (store (gensym)) + (stemp (first stores))) (values `(,btemp ,@temps) - `(,bytespec ,@vals) - `(,store) - `(let ((,stemp (dpb ,store ,btemp ,access-form))) - ,store-form ,store) - `(ldb ,btemp ,access-form))))) + `(,bytespec ,@vals) + `(,store) + `(let ((,stemp (dpb ,store ,btemp ,access-form))) + ,store-form ,store) + `(ldb ,btemp ,access-form))))) (define-setf-expander mask-field (&environment env bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (let* ((btemp (gensym)) - (store (gensym)) - (stemp (first stores))) + (store (gensym)) + (stemp (first stores))) (values `(,btemp ,@temps) - `(,bytespec ,@vals) - `(,store) - `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) - ,store-form ,store) - `(mask-field ,btemp ,access-form))))) + `(,bytespec ,@vals) + `(,store) + `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) + ,store-form ,store) + `(mask-field ,btemp ,access-form))))) (defun trivial-setf-form (place vars stores store-form access-form) (declare (si::c-local) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (and (atom place) (null vars) (eq access-form place) @@ -324,48 +324,48 @@ Does not check if the third gang is a single-element list." ;; followed by a single stored value, we can produce an expansion ;; without LET forms. (declare (si::c-local) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (when (and (consp place) - (consp store-form) - (= (length place) (truly-the fixnum (1- (length store-form))))) + (consp store-form) + (= (length place) (truly-the fixnum (1- (length store-form))))) (let ((function (pop store-form)) - (output '()) - v) + (output '()) + v) (dolist (i (rest place) - (when (eq (first stores) (first store-form)) - (list* function - (nreverse (cons newvalue output))))) - (unless (consp store-form) - (return nil)) - (setq v (car (truly-the cons store-form)) - store-form (cdr (truly-the cons store-form))) - ;; This checks that the argument at this position coincides with - ;; the corresponding value in the original list. Note that the - ;; variable list need not be in order. - (unless (or (eq v i) - (and (eq v (pop vars)) - (eq (pop vals) i))) - (return nil)) - (push i output))))) + (when (eq (first stores) (first store-form)) + (list* function + (nreverse (cons newvalue output))))) + (unless (consp store-form) + (return nil)) + (setq v (car (truly-the cons store-form)) + store-form (cdr (truly-the cons store-form))) + ;; This checks that the argument at this position coincides with + ;; the corresponding value in the original list. Note that the + ;; variable list need not be in order. + (unless (or (eq v i) + (and (eq v (pop vars)) + (eq (pop vals) i))) + (return nil)) + (push i output))))) ;;; The expansion function for SETF. (defun setf-expand-1 (place newvalue env) (declare (si::c-local) - (notinline mapcar)) + (notinline mapcar)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) (cond ((trivial-setf-form place vars stores store-form access-form) - (list 'setq place newvalue)) - ((try-simpler-expansion place vars vals stores newvalue store-form)) - (t - `(let* ,(mapcar #'list vars vals) - ;; Unfortunately we cannot do this because there is code out - ;; there that changes the variables and values - ;; (declare (:read-only ,@vars)) - (multiple-value-bind ,stores ,newvalue - ;; Same here - ;; (declare (:read-only ,@stores)) - ,store-form)))))) + (list 'setq place newvalue)) + ((try-simpler-expansion place vars vals stores newvalue store-form)) + (t + `(let* ,(mapcar #'list vars vals) + ;; Unfortunately we cannot do this because there is code out + ;; there that changes the variables and values + ;; (declare (:read-only ,@vars)) + (multiple-value-bind ,stores ,newvalue + ;; Same here + ;; (declare (:read-only ,@stores)) + ,store-form)))))) (defun setf-expand (l env) (declare (si::c-local)) @@ -384,13 +384,13 @@ Each PLACE may be any one of the following: * A symbol that names a variable. * A function call form whose first element is the name of the following functions: - nth elt subseq rest first ... tenth - c?r c??r c???r c????r - aref svref char schar bit sbit fill-pointer - get getf documentation symbol-value symbol-function - symbol-plist macro-function gethash fdefinition - char-bit ldb mask-field - apply slot-value + nth elt subseq rest first ... tenth + c?r c??r c???r c????r + aref svref char schar bit sbit fill-pointer + get getf documentation symbol-value symbol-function + symbol-plist macro-function gethash fdefinition + char-bit ldb mask-field + apply slot-value where '?' stands for either 'a' or 'd'. * A function call form whose first element is: 1. an access function for a structure slot @@ -505,7 +505,7 @@ a form (SYMBOL place form1 ... formn) into a form that in effect SETFs the value of (FUNCTION-NAME place arg1 ... argm) into PLACE, where ARG1 ... ARGm are parameters in LAMBDA-LIST which are bound to FORM1 ... FORMn. For example, INCF could be defined as - (define-modify-macro incf (&optional (x 1)) +) + (define-modify-macro incf (&optional (x 1)) +) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)." (let* ((varlist nil) @@ -544,46 +544,46 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)." (DECLARE (NOTINLINE MAPCAR)) (MULTIPLE-VALUE-BIND (VARS VALS STORES SETTER GETTER) (GET-SETF-EXPANSION %REFERENCE ENV) - (LET ((ALL-VARS (MAPCAR #'(LAMBDA (V) (LIST (GENSYM) V)) (LIST* ,@varlist ,restvar)))) - (IF (SYMBOLP GETTER) - (SUBST (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS)) + (LET ((ALL-VARS (MAPCAR #'(LAMBDA (V) (LIST (GENSYM) V)) (LIST* ,@varlist ,restvar)))) + (IF (SYMBOLP GETTER) + (SUBST (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS)) (CAR STORES) `(LET* ,ALL-VARS - (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars))) - ,SETTER)) - (DO ((D VARS (CDR D)) - (V VALS (CDR V)) - (LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST))) - ((NULL D) - (SETQ LET-LIST - (LIST* - (LIST - (CAR STORES) - (IF (AND (LISTP %REFERENCE) (EQ (CAR %REFERENCE) 'THE)) - (LIST 'THE (CADR %REFERENCE) - (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)) - (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS)))) - (APPEND ALL-VARS LET-LIST))) - `(LET* ,(NREVERSE LET-LIST) - (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars) - ,@vars)) - ,SETTER))))))))) + (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars))) + ,SETTER)) + (DO ((D VARS (CDR D)) + (V VALS (CDR V)) + (LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST))) + ((NULL D) + (SETQ LET-LIST + (LIST* + (LIST + (CAR STORES) + (IF (AND (LISTP %REFERENCE) (EQ (CAR %REFERENCE) 'THE)) + (LIST 'THE (CADR %REFERENCE) + (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)) + (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS)))) + (APPEND ALL-VARS LET-LIST))) + `(LET* ,(NREVERSE LET-LIST) + (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars) + ,@vars)) + ,SETTER))))))))) #| (defmacro define-modify-macro (name lambda-list function &optional doc-string) (let ((update-form - (do ((l lambda-list (cdr l)) - (vs nil)) - ((null l) `(list ',function access-form ,@(nreverse vs))) - (unless (eq (car l) '&optional) - (if (eq (car l) '&rest) - (return `(list* ',function - access-form - ,@(nreverse vs) - ,(cadr l)))) - (if (symbolp (car l)) - (setq vs (cons (car l) vs)) - (setq vs (cons (caar l) vs))))))) + (do ((l lambda-list (cdr l)) + (vs nil)) + ((null l) `(list ',function access-form ,@(nreverse vs))) + (unless (eq (car l) '&optional) + (if (eq (car l) '&rest) + (return `(list* ',function + access-form + ,@(nreverse vs) + ,(cadr l)))) + (if (symbolp (car l)) + (setq vs (cons (car l) vs)) + (setq vs (cons (caar l) vs))))))) `(defmacro ,name (&environment env reference . ,lambda-list) ,@(if doc-string (list doc-string)) (when (symbolp reference) @@ -591,12 +591,12 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)." (let ((access-form reference)) (list 'setq reference ,update-form)))) (multiple-value-bind (vars vals stores store-form access-form) - (get-setf-expansion reference env) + (get-setf-expansion reference env) `(let* ,(mapcar #'list - (append vars stores) - (append vals (list ,update-form))) - (declare (:read-only ,@stores)) ; Beppe - ,store-form))))) + (append vars stores) + (append vals (list ,update-form))) + (declare (:read-only ,@stores)) ; Beppe + ,store-form))))) |# ;;; Some macro definitions. @@ -636,11 +636,11 @@ makes it the new value of PLACE. Returns the new value of PLACE." ;; The item to be pushed has to be evaluated before the destination (unless (constantp item env) (setq vals (cons item vals) - item (gensym) - vars (cons item vars))) + item (gensym) + vars (cons item vars))) `(let* ,(mapcar #'list - (append vars stores) - (append vals (list (list 'cons item access-form)))) + (append vars stores) + (append vals (list (list 'cons item access-form)))) (declare (:read-only ,@vars)) ; Beppe ,store-form))) @@ -659,12 +659,12 @@ to MEMBER." ;; The item to be pushed has to be evaluated before the destination (unless (constantp item env) (setq vals (cons item vals) - item (gensym) - vars (cons item vars))) + item (gensym) + vars (cons item vars))) `(let* ,(mapcar #'list - (append vars stores) - (append vals - (list (list* 'adjoin item access-form rest)))) + (append vars stores) + (append vals + (list (list* 'adjoin item access-form rest)))) (declare (:read-only ,@vars)) ; Beppe ,store-form))) @@ -677,36 +677,36 @@ Returns the car of the old value in PLACE." (get-setf-expansion place env) (let ((store-var (first stores))) `(let* ,(mapcar #'list - (append vars stores) - (append vals (list access-form))) - (declare (:read-only ,@vars)) ; Beppe - (prog1 (car ,store-var) - (setq ,store-var (cdr (truly-the list ,store-var))) - ,store-form))))) + (append vars stores) + (append vals (list access-form))) + (declare (:read-only ,@vars)) ; Beppe + (prog1 (car ,store-var) + (setq ,store-var (cdr (truly-the list ,store-var))) + ,store-form))))) (define-setf-expander values (&rest values &environment env) (let ((all-vars '()) - (all-vals '()) - (all-stores '()) - (all-storing-forms '()) - (all-get-forms '())) + (all-vals '()) + (all-stores '()) + (all-storing-forms '()) + (all-get-forms '())) (dolist (item (reverse values)) (multiple-value-bind (vars vals stores storing-form get-form) - (get-setf-expansion item env) - ;; If a place has more than one store variable, the other ones - ;; are set to nil. - (let ((extra (rest stores))) - (unless (endp extra) - (setf vars (append extra vars) - vals (append (make-list (length extra)) vals) - stores (list (first stores))))) - (setf all-vars (append vars all-vars) - all-vals (append vals all-vals) - all-stores (append stores all-stores) - all-storing-forms (cons storing-form all-storing-forms) - all-get-forms (cons get-form all-get-forms)))) + (get-setf-expansion item env) + ;; If a place has more than one store variable, the other ones + ;; are set to nil. + (let ((extra (rest stores))) + (unless (endp extra) + (setf vars (append extra vars) + vals (append (make-list (length extra)) vals) + stores (list (first stores))))) + (setf all-vars (append vars all-vars) + all-vals (append vals all-vals) + all-stores (append stores all-stores) + all-storing-forms (cons storing-form all-storing-forms) + all-get-forms (cons get-form all-get-forms)))) (values all-vars all-vals all-stores `(values ,@all-storing-forms) - `(values ,@all-get-forms)))) + `(values ,@all-get-forms)))) #| ;;; Proposed extension: ; Expansion of (SETF (VALUES place1 ... placek) form) @@ -719,10 +719,10 @@ Returns the car of the old value in PLACE." (placesr subplaces)) ((atom placesr) (setq temps (nreverse temps) - vals (nreverse vals) - stores (nreverse stores) - storeforms (nreverse storeforms) - accessforms (nreverse accessforms)) + vals (nreverse vals) + stores (nreverse stores) + storeforms (nreverse storeforms) + accessforms (nreverse accessforms)) (values temps vals stores @@ -731,8 +731,8 @@ Returns the car of the old value in PLACE." (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-expansion (pop placesr) env) (setq temps (revappend SM1 temps) - vals (revappend SM2 vals) - stores (revappend SM3 stores) - storeforms (cons SM4 storeforms) - accessforms (cons SM5 accessforms))))) + vals (revappend SM2 vals) + stores (revappend SM3 stores) + storeforms (cons SM4 storeforms) + accessforms (cons SM5 accessforms))))) |# diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 6177a715b..91d2253f2 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -23,11 +23,11 @@ (in-package "SYSTEM") (export '(*break-readtable* *break-on-warnings* - *tpl-evalhook* *tpl-prompt-hook*)) + *tpl-evalhook* *tpl-prompt-hook*)) (defparameter *quit-tag* (cons nil nil)) (defparameter *quit-tags* nil) -(defparameter *break-level* 0) ; nesting level of error loops +(defparameter *break-level* 0) ; nesting level of error loops (defparameter *break-env* nil) (defparameter *ihs-base* 0) (defparameter *ihs-top* (ihs-top)) @@ -43,8 +43,8 @@ (defparameter *break-message* nil) (defparameter *break-readtable* nil) -(defparameter *tpl-level* -1) ; nesting level of top-level loops -(defparameter *step-level* 0) ; repeated from trace.lsp +(defparameter *tpl-level* -1) ; nesting level of top-level loops +(defparameter *step-level* 0) ; repeated from trace.lsp (defparameter *break-hidden-functions* '(error cerror apply funcall invoke-debugger)) (defparameter *break-hidden-packages* (list #-ecl-min (find-package 'system))) @@ -52,49 +52,49 @@ (defconstant tpl-commands '(("Top level commands" ((:cf :compile-file) tpl-compile-command :string - ":cf Compile file" - ":compile-file &string &rest files [Top level command]~@ - :cf &string &rest files [Abbreviation]~@ - ~@ - Compile files. With no arguments, uses values from latest :cf~@ - command. File extensions are optional.~%") + ":cf Compile file" + ":compile-file &string &rest files [Top level command]~@ + :cf &string &rest files [Abbreviation]~@ + ~@ + Compile files. With no arguments, uses values from latest :cf~@ + command. File extensions are optional.~%") ((:exit :eof) quit :eval - ":exit or ^D Exit Lisp" - ":exit &eval &optional (status 0) [Top level command]~@ - ~@ - Exit Lisp without further confirmation.~%") + ":exit or ^D Exit Lisp" + ":exit &eval &optional (status 0) [Top level command]~@ + ~@ + Exit Lisp without further confirmation.~%") ((:ld :load) tpl-load-command :string - ":ld Load file" - ":load &string &rest files [Top level command]~@ - :ld &string &rest files [Abbreviation]~@ - ~@ - Load files. With no arguments, uses values from latest :ld~@ - or :cf command. File extensions are optional.~%") + ":ld Load file" + ":load &string &rest files [Top level command]~@ + :ld &string &rest files [Abbreviation]~@ + ~@ + Load files. With no arguments, uses values from latest :ld~@ + or :cf command. File extensions are optional.~%") ((:step) tpl-step-command nil - ":step Single step form" - ":step form [Top level command]~@ - ~@ - Evaluate form in single step mode. While stepping, a new break~@ - level is invoked before every evaluation. Extra commands are~@ - available at this time to control stepping and form evaluation.~%") + ":step Single step form" + ":step form [Top level command]~@ + ~@ + Evaluate form in single step mode. While stepping, a new break~@ + level is invoked before every evaluation. Extra commands are~@ + available at this time to control stepping and form evaluation.~%") ((:tr :trace) tpl-trace-command nil - ":tr(ace) Trace function" - ":trace &rest functions [Top level command]~@ - :tr &rest functions [Abbreviation]~@ - ~@ - Trace specified functions. With no arguments, show currently~@ - traced functions.~@ - ~@ - See also: :untrace.~%") + ":tr(ace) Trace function" + ":trace &rest functions [Top level command]~@ + :tr &rest functions [Abbreviation]~@ + ~@ + Trace specified functions. With no arguments, show currently~@ + traced functions.~@ + ~@ + See also: :untrace.~%") ((:untr :untrace) tpl-untrace-command nil - ":untr(ace) Untrace function" - ":untrace &rest functions [Top level command]~@ - :untr &rest functions [Abbreviation]~@ - ~@ - Untrace specified functions. With no arguments, untrace~@ - all functions.~@ - ~@ - See also: :trace.~%") + ":untr(ace) Untrace function" + ":untrace &rest functions [Top level command]~@ + :untr &rest functions [Abbreviation]~@ + ~@ + Untrace specified functions. With no arguments, untrace~@ + all functions.~@ + ~@ + See also: :trace.~%") #+threads ((:s :switch) tpl-switch-command nil ":s(witch) Switch to next process to debug" @@ -123,41 +123,41 @@ ) ("Help commands" ((:apropos) tpl-apropos-command nil - ":apropos Apropos" - ":apropos string &optional package [Top level command]~@ - ~@ - Finds all available symbols whose print names contain string.~@ - If a non NIL package is specified, only symbols in that package are considered.~@ - ~%") + ":apropos Apropos" + ":apropos string &optional package [Top level command]~@ + ~@ + Finds all available symbols whose print names contain string.~@ + If a non NIL package is specified, only symbols in that package are considered.~@ + ~%") ((:doc document) tpl-document-command nil - ":doc(ument) Document" - ":document symbol [Top level command]~@ - ~@ - Displays documentation about function, print names contain string.~%") + ":doc(ument) Document" + ":document symbol [Top level command]~@ + ~@ + Displays documentation about function, print names contain string.~%") ((? :h :help) tpl-help-command nil - ":h(elp) or ? Help. Type \":help help\" for more information" - ":help &optional topic [Top level command]~@ - :h &optional topic [Abbrevation]~@ - ~@ - Print information on specified topic. With no arguments, print~@ - quick summery of top level commands.~@ - ~@ - Help information for top level commands follows the documentation~@ - style found in \"Common Lisp, the Language\"; and, in general, the~@ - commands themselves follow the conventions of Common Lisp functions,~@ - with the exception that arguments are normally not evaluated.~@ - Those commands that do evaluate their arguments are indicated by the~@ - keyword &eval in their description. A third class of commands~@ - treat their arguments as whitespace-separated, case-sensitive~@ - strings, requiring double quotes only when necessary. This style~@ - of argument processing is indicated by the keyword &string.~@ - For example, the :load command accepts a list of file names: - ~@ - :load &string &rest files [Top level Command]~@ - ~@ - whereas :exit, which requires an optional evaluated argument, is~@ - ~@ - :exit &eval &optional status [Top level Command]~%") + ":h(elp) or ? Help. Type \":help help\" for more information" + ":help &optional topic [Top level command]~@ + :h &optional topic [Abbrevation]~@ + ~@ + Print information on specified topic. With no arguments, print~@ + quick summery of top level commands.~@ + ~@ + Help information for top level commands follows the documentation~@ + style found in \"Common Lisp, the Language\"; and, in general, the~@ + commands themselves follow the conventions of Common Lisp functions,~@ + with the exception that arguments are normally not evaluated.~@ + Those commands that do evaluate their arguments are indicated by the~@ + keyword &eval in their description. A third class of commands~@ + treat their arguments as whitespace-separated, case-sensitive~@ + strings, requiring double quotes only when necessary. This style~@ + of argument processing is indicated by the keyword &string.~@ + For example, the :load command accepts a list of file names: + ~@ + :load &string &rest files [Top level Command]~@ + ~@ + whereas :exit, which requires an optional evaluated argument, is~@ + ~@ + :exit &eval &optional status [Top level Command]~%") ))) (defparameter *tpl-commands* tpl-commands) @@ -165,211 +165,211 @@ (defconstant break-commands '("Break commands" ((:q :quit) tpl-quit-command nil - ":q(uit) Return to some previous break level" - ":quit &optional n [Break command]~@ - :q &optional n [Abbreviation]~@ - ~@ - Without argument, return to top level;~@ - otherwise return to break level n.~%") + ":q(uit) Return to some previous break level" + ":quit &optional n [Break command]~@ + :q &optional n [Abbreviation]~@ + ~@ + Without argument, return to top level;~@ + otherwise return to break level n.~%") ((:pop) (tpl-pop-command) :constant - ":pop Pop to previous break level" - ":pop [Break command]~@ - ~@ - Pop to previous break level, or if already in top level,~@ - exit Lisp after confirmation.~%") + ":pop Pop to previous break level" + ":pop [Break command]~@ + ~@ + Pop to previous break level, or if already in top level,~@ + exit Lisp after confirmation.~%") ((:c :continue) continue nil - ":c(ontinue) Continue execution" - ":continue [Break command]~@ - :c [Abbreviation]~@ - ~@ - Continue execution. Return from current break level to the caller.~@ - This command is only available when the break level is continuable~@ - (e.g., called from a correctable error or the function break).~%") + ":c(ontinue) Continue execution" + ":continue [Break command]~@ + :c [Abbreviation]~@ + ~@ + Continue execution. Return from current break level to the caller.~@ + This command is only available when the break level is continuable~@ + (e.g., called from a correctable error or the function break).~%") ((:b :backtrace) tpl-backtrace nil - ":b(acktrace) Print backtrace" - ":backtrace &optional n [Break command]~@ - :b &optional n [Abbreviation]~@ - ~@ - Show function call history. Only those functions called since~@ - the previous break level are shown. In addition, functions compiled~@ - in-line or explicitly hidden are not displayed. Without an argument,~@ - a concise backtrace is printed with the current function in upper~@ - case. With integer argument n, the n functions above and including~@ - the current one are printed in a verbose format.~@ - ~@ - See also: :function, :previous, :next.~%") + ":b(acktrace) Print backtrace" + ":backtrace &optional n [Break command]~@ + :b &optional n [Abbreviation]~@ + ~@ + Show function call history. Only those functions called since~@ + the previous break level are shown. In addition, functions compiled~@ + in-line or explicitly hidden are not displayed. Without an argument,~@ + a concise backtrace is printed with the current function in upper~@ + case. With integer argument n, the n functions above and including~@ + the current one are printed in a verbose format.~@ + ~@ + See also: :function, :previous, :next.~%") ((:f :function) tpl-print-current nil - ":f(unction) Show current function" - ":function [Break command]~@ - :f [Abbreviation]~@ - ~@ - Show current function. The current function is the implicit focus~@ - of attention for several other commands. When it is an interpreted~@ - function, its lexical environment is available for inspection and~@ - becomes the environment for evaluating user input forms.~@ - ~@ - See also: :backtrace, :next, previous, :disassemble, :variables.~%") + ":f(unction) Show current function" + ":function [Break command]~@ + :f [Abbreviation]~@ + ~@ + Show current function. The current function is the implicit focus~@ + of attention for several other commands. When it is an interpreted~@ + function, its lexical environment is available for inspection and~@ + becomes the environment for evaluating user input forms.~@ + ~@ + See also: :backtrace, :next, previous, :disassemble, :variables.~%") ((:p :previous) tpl-previous nil - ":p(revious) Go to previous function" - ":previous &optional (n 1) [Break command]~@ - :p &optional (n 1) [Abbreviation]~@ - ~@ - Move to the nth previous visible function in the backtrace.~@ - It becomes the new current function.~@ - ~@ - See also: :backtrace, :function, :go, :next.~%") + ":p(revious) Go to previous function" + ":previous &optional (n 1) [Break command]~@ + :p &optional (n 1) [Abbreviation]~@ + ~@ + Move to the nth previous visible function in the backtrace.~@ + It becomes the new current function.~@ + ~@ + See also: :backtrace, :function, :go, :next.~%") ((:d :down) tpl-previous nil ":d(own) Alias to :previous" "" ) ((:n :next) tpl-next nil - ":n(ext) Go to next function" - ":next &optional (n 1) [Break command]~@ - :n &optional (n 1) [Abbreviation]~@ - ~@ - Move to the nth next visible function in the backtrace. It becomes~@ - the new current function.~@ - ~@ - See also: :backtrace, :function, :go, :previous.~%") + ":n(ext) Go to next function" + ":next &optional (n 1) [Break command]~@ + :n &optional (n 1) [Abbreviation]~@ + ~@ + Move to the nth next visible function in the backtrace. It becomes~@ + the new current function.~@ + ~@ + See also: :backtrace, :function, :go, :previous.~%") ((:u :up) tpl-next nil ":u(p) Alias to :next" "" ) ((:g :go) tpl-go nil - ":g(o) Go to next function" - ":go &optional (n 1) [Break command]~@ - :g &optional (n 1) [Abbreviation]~@ - ~@ - Move to the function at IHS[i].~@ - See also: :backtrace, :function, :next, :previous.~%") + ":g(o) Go to next function" + ":go &optional (n 1) [Break command]~@ + :g &optional (n 1) [Abbreviation]~@ + ~@ + Move to the function at IHS[i].~@ + See also: :backtrace, :function, :next, :previous.~%") ((:fs :forward-search) tpl-forward-search :string ":fs Search forward for function" - ":forward-search &string substring [Break command]~@ - :fs &string substring [Abbreviation]~@ - ~@ - Search forward in the backtrace for function containing substring.~@ - The match is case insensitive.~@ - ~@ - See also: :backtrace, :function, :next.~%") + ":forward-search &string substring [Break command]~@ + :fs &string substring [Abbreviation]~@ + ~@ + Search forward in the backtrace for function containing substring.~@ + The match is case insensitive.~@ + ~@ + See also: :backtrace, :function, :next.~%") ((:bs :backward-search) tpl-backward-search :string ":bs Search backward for function" - ":backward-search &string substring [Break command]~@ - :bs &string substring [Abbreviation]~@ - ~@ - Search backward in the backtrace for function containing substring.~@ - The match is case insensitive.~@ - ~@ - See also: :backtrace, :function, :previous.~%") + ":backward-search &string substring [Break command]~@ + :bs &string substring [Abbreviation]~@ + ~@ + Search backward in the backtrace for function containing substring.~@ + The match is case insensitive.~@ + ~@ + See also: :backtrace, :function, :previous.~%") ((:disassemble) tpl-disassemble-command nil - ":disassemble Disassemble current function" - ":disassemble [Break command]~@ - :disassemble [Abbreviation]~@ - ~@ - Disassemble the current function. Currently, only interpreted functions~@ - can be disassembled.~%") + ":disassemble Disassemble current function" + ":disassemble [Break command]~@ + :disassemble [Abbreviation]~@ + ~@ + Disassemble the current function. Currently, only interpreted functions~@ + can be disassembled.~%") ((:le :lambda-expression) tpl-lambda-expression-command nil - ":l(ambda-)e(expression) Show lisp code for current function" - ":lambda-expression [Break command]~@ - :le [Abbreviation]~@ - ~@ - Show the lisp code of the current function. Only works for interpreted~@ + ":l(ambda-)e(expression) Show lisp code for current function" + ":lambda-expression [Break command]~@ + :le [Abbreviation]~@ + ~@ + Show the lisp code of the current function. Only works for interpreted~@ functions.~%") ((:v :variables) tpl-variables-command nil - ":v(ariables) Show local variables, functions, blocks, and tags" - ":variables &optional no-values [Break command]~@ - :v &optional no-values [Abbreviation]~@ - ~@ - Show lexical variables, functions, block names, and tags local~@ - to the current function. The current function must be interpreted.~@ - The values of local variables and functions are also shown,~@ - unless the argument is non-null.~%") + ":v(ariables) Show local variables, functions, blocks, and tags" + ":variables &optional no-values [Break command]~@ + :v &optional no-values [Abbreviation]~@ + ~@ + Show lexical variables, functions, block names, and tags local~@ + to the current function. The current function must be interpreted.~@ + The values of local variables and functions are also shown,~@ + unless the argument is non-null.~%") #| ((:l :local) tpl-local-command nil - ":l(ocal) Return the nth local value on the stack" - ":local &optional (n 0) [Break command]~@ - :l &optional (n 0) [Abbreviation] - ~@ - For compiled functions, return the value of the nth lexical variable.~@ - As is done normally, the returned value is both printed by the top~@ - level as well as saved in the variable *.~%") + ":l(ocal) Return the nth local value on the stack" + ":local &optional (n 0) [Break command]~@ + :l &optional (n 0) [Abbreviation] + ~@ + For compiled functions, return the value of the nth lexical variable.~@ + As is done normally, the returned value is both printed by the top~@ + level as well as saved in the variable *.~%") |# ((:hide) tpl-hide nil - ":hide Hide function" - ":hide function [Break command]~@ - ~@ - Hide function. A hidden function is not displayed in a backtrace.~@ - ~@ - See also: :backtrace, :unhide, :hide-package.~%") + ":hide Hide function" + ":hide function [Break command]~@ + ~@ + Hide function. A hidden function is not displayed in a backtrace.~@ + ~@ + See also: :backtrace, :unhide, :hide-package.~%") ((:unhide) tpl-unhide nil - ":unhide Unhide function" - ":unhide function [Break command]~@ - ~@ - Unhide function. The specified function will be displayed in future~@ - backtraces, unless its home package is also hidden.~@ - ~@ - See also: :backtrace, :hide, :unhide-package.~%") + ":unhide Unhide function" + ":unhide function [Break command]~@ + ~@ + Unhide function. The specified function will be displayed in future~@ + backtraces, unless its home package is also hidden.~@ + ~@ + See also: :backtrace, :hide, :unhide-package.~%") ((:hp :hide-package) tpl-hide-package nil - ":hp Hide package" - ":hide-package package [Break command]~@ - :hp package [Abbreviation]~@ - ~@ - Hide package. Functions in a hidden package are not displayed~@ - in a backtrace.~@ - ~@ - See also: :backtrace, :unhide-package.~%") + ":hp Hide package" + ":hide-package package [Break command]~@ + :hp package [Abbreviation]~@ + ~@ + Hide package. Functions in a hidden package are not displayed~@ + in a backtrace.~@ + ~@ + See also: :backtrace, :unhide-package.~%") ((:unhp :unhide-package) tpl-unhide-package nil - ":unhp Unhide package" - ":unhide-package package [Break command]~@ - :unhp package [Abbreviation]~@ - ~@ - Unhide package. Functions in the specified package will be displayed~@ - in future backtraces, unless they are individually hidden.~@ - ~@ - See also: :backtrace, :hide-package, :hide, :unhide.~%") + ":unhp Unhide package" + ":unhide-package package [Break command]~@ + :unhp package [Abbreviation]~@ + ~@ + Unhide package. Functions in the specified package will be displayed~@ + in future backtraces, unless they are individually hidden.~@ + ~@ + See also: :backtrace, :hide-package, :hide, :unhide.~%") ((:unhide-all) tpl-unhide-all nil ":unhide-all Unhide all variables and packages" - ":unhide-all [Break command]~@ - ~@ - Unhide all variables and packages. All functions will be displayed~@ - in future backtraces.~@ - ~@ - See also: :hide, :unhide, :hide-package, :unhide-package.~%") + ":unhide-all [Break command]~@ + ~@ + Unhide all variables and packages. All functions will be displayed~@ + in future backtraces.~@ + ~@ + See also: :hide, :unhide, :hide-package, :unhide-package.~%") #| ((:vs :value-stack) tpl-vs-command nil ":vs Show value stack" - ":value-stack &optional n [Break command]~@ - :vs &optional n [Abbreviation]~@ - ~@ - Without an argument, show the entire value stack since the previous~@ - break level. With an integer argument n, print nothing, but return~@ - the nth value stack entry.~@ - ~@ - See also: :local.~%") + ":value-stack &optional n [Break command]~@ + :vs &optional n [Abbreviation]~@ + ~@ + Without an argument, show the entire value stack since the previous~@ + break level. With an integer argument n, print nothing, but return~@ + the nth value stack entry.~@ + ~@ + See also: :local.~%") |# ((:bds :binding-stack) tpl-bds-command nil ":bds Show binding stack" - ":binding-stack &optional variable [Break command]~@ - :bds &optional variable [Abbreviation]~@ - ~@ - Without an argument, show the entire binding stack since the previous~@ - break level. With a variable name, print nothing, but return the~@ - value of the given variable on the binding stack.~%") + ":binding-stack &optional variable [Break command]~@ + :bds &optional variable [Abbreviation]~@ + ~@ + Without an argument, show the entire binding stack since the previous~@ + break level. With a variable name, print nothing, but return the~@ + value of the given variable on the binding stack.~%") ((:frs :frame-stack) tpl-frs-command nil ":frs Show frame stack" "" ) ((:m :message) tpl-print-message nil ":m(essage) Show error message" - ":message [Break command]~@ - :m [Abbreviation]~@ - ~@ - Show current error message.~%") + ":message [Break command]~@ + :m [Abbreviation]~@ + ~@ + Show current error message.~%") ((:hs :help-stack) tpl-help-stack-command nil - ":hs Help stack" - ":help-stack [Break command]~@ - :hs [Abbrevation]~@ - ~@ - Lists the functions to access the LISP system stacks.~%") + ":hs Help stack" + ":help-stack [Break command]~@ + :hs [Abbrevation]~@ + ~@ + Lists the functions to access the LISP system stacks.~%") ((:i :inspect) tpl-inspect-command nil ":i(nspect) Inspect value of local variable" ":inspect var-name [Break command]~@ @@ -390,26 +390,26 @@ ECL specific. The top-level loop of ECL. It is called by default when ECL is invoked." (catch *quit-tag* (let* ((*debugger-hook* nil) - + ++ +++ - * ** *** / // ///) + + ++ +++ - * ** *** / // ///) (in-package "CL-USER") (unless (or *lisp-initialized* (null process-command-line)) (process-command-args) - (format t "ECL (Embeddable Common-Lisp) ~A (git:~D)" + (format t "ECL (Embeddable Common-Lisp) ~A (git:~D)" (lisp-implementation-version) (ext:lisp-implementation-vcs-id)) - (format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@ + (format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@ Copyright (C) 1993 Giuseppe Attardi~@ Copyright (C) 2000 Juan J. Garcia-Ripoll Copyright (C) 2015 Daniel Kochmanski ECL is free software, and you are welcome to redistribute it~@ under certain conditions; see file 'Copyright' for details.") - (format *standard-output* "~%Type :h for Help. ")) + (format *standard-output* "~%Type :h for Help. ")) (setq *lisp-initialized* t) (let ((*tpl-level* -1)) - (tpl)) + (tpl)) 0))) #+threads @@ -471,27 +471,27 @@ under certain conditions; see file 'Copyright' for details.") #+threads (defun show-process-list (&optional (process-list (mp:all-processes))) (loop with current = mp:*current-process* - for rank from 1 - for process in process-list - do (format t (if (eq process current) - "~% >~D: ~s" - "~% ~D: ~s") - rank process))) + for rank from 1 + for process in process-list + do (format t (if (eq process current) + "~% >~D: ~s" + "~% ~D: ~s") + rank process))) #+threads (defun query-process (&optional (process-list (mp:all-processes))) (format t "~&Choose the integer code of process to interrupt. Use special code 0 to cancel this operation.") (loop for code = (progn - (show-process-list process-list) - (tpl-prompt) - (tpl-read)) - do (cond ((zerop code) - (return nil)) - ((and (fixnump code) (<= 1 code (length process-list))) - (return (list (elt process-list (1- code))))) - (t - (format t "~&Not a valid process number"))))) + (show-process-list process-list) + (tpl-prompt) + (tpl-read)) + do (cond ((zerop code) + (return nil)) + ((and (fixnump code) (<= 1 code (length process-list))) + (return (list (elt process-list (1- code))))) + (t + (format t "~&Not a valid process number"))))) (defparameter *interrupt-lonely-threads-p* t) @@ -504,57 +504,57 @@ Use special code 0 to cancel this operation.") #+threads (mp:without-interrupts (let* ((suspended '()) - (break-process nil) - (all-processes - (loop with this = mp:*current-process* - for p in (mp:all-processes) - unless (or (eq p this) - (member (mp:process-name p) + (break-process nil) + (all-processes + (loop with this = mp:*current-process* + for p in (mp:all-processes) + unless (or (eq p this) + (member (mp:process-name p) '(si:signal-servicing si::handle-signal))) - collect p))) + collect p))) (when (and (= (length all-processes) 1) *interrupt-lonely-threads-p*) (mp:interrupt-process (first all-processes) - #'single-threaded-terminal-interrupt) + #'single-threaded-terminal-interrupt) (return-from terminal-interrupt)) (loop for i in all-processes - do (progn (format t "~%;;; Suspending process ~A" i) - (push i suspended) - (mp:process-suspend i))) + do (progn (format t "~%;;; Suspending process ~A" i) + (push i suspended) + (mp:process-suspend i))) (flet ((do-query-process () (print all-processes) - (query-process all-processes))) + (query-process all-processes))) (mp:with-local-interrupts - (restart-case (simple-terminal-interrupt) + (restart-case (simple-terminal-interrupt) (continue () (setf break-process nil)) - (mp:interrupt-process (process) - :interactive do-query-process - :report (lambda (stream) (princ "Interrupt a certain process." stream)) - (setf break-process process))))) + (mp:interrupt-process (process) + :interactive do-query-process + :report (lambda (stream) (princ "Interrupt a certain process." stream)) + (setf break-process process))))) (loop for process in suspended unless (eq process break-process) do (mp:process-resume process)) (when break-process (mp:interrupt-process break-process - #'single-threaded-terminal-interrupt)))) + #'single-threaded-terminal-interrupt)))) #-threads (single-threaded-terminal-interrupt)) (defun tpl (&key ((:commands *tpl-commands*) tpl-commands) - ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*) - (broken-at nil) - (quiet nil)) + ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*) + (broken-at nil) + (quiet nil)) #-ecl-min (declare (c::policy-debug-ihs-frame)) (let* ((*ihs-base* *ihs-top*) - (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top))) - (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*)) - (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) - (*frs-top* (frs-top)) - (*quit-tags* (cons *quit-tag* *quit-tags*)) - (*quit-tag* *quit-tags*) ; any unique new value - (*tpl-level* (1+ *tpl-level*)) - (break-level *break-level*) - values) + (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top))) + (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*)) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*quit-tags* (cons *quit-tag* *quit-tags*)) + (*quit-tag* *quit-tags*) ; any unique new value + (*tpl-level* (1+ *tpl-level*)) + (break-level *break-level*) + values) (set-break-env) (set-current-ihs) (flet ((rep () @@ -566,22 +566,22 @@ Use special code 0 to cancel this operation.") ;; and which expect nothing to happen by default. (handler-bind ((serious-condition - (lambda (condition) - (cond ((< break-level 1) - ;; Toplevel should enter the debugger on any condition. - ) - (*allow-recursive-debug* - ;; We are told to let the debugger handle this. - ) - (t - (format t "~&Debugger received error of type: ~A~%~A~%~ + (lambda (condition) + (cond ((< break-level 1) + ;; Toplevel should enter the debugger on any condition. + ) + (*allow-recursive-debug* + ;; We are told to let the debugger handle this. + ) + (t + (format t "~&Debugger received error of type: ~A~%~A~%~ Error flushed.~%" - (type-of condition) condition) - (clear-input) - (return-from rep t) ;; go back into the debugger loop. - ) - ) - ))) + (type-of condition) condition) + (clear-input) + (return-from rep t) ;; go back into the debugger loop. + ) + ) + ))) (with-grabbed-console (unless quiet @@ -594,19 +594,19 @@ Use special code 0 to cancel this operation.") (eval-with-env - *break-env*)) /// // // / / values *** ** ** * * (car /)) (tpl-print values))))) - (loop - (setq +++ ++ ++ + + -) - (when - (catch *quit-tag* - (if (zerop break-level) - (with-simple-restart + (loop + (setq +++ ++ ++ + + -) + (when + (catch *quit-tag* + (if (zerop break-level) + (with-simple-restart (restart-toplevel "Go back to Top-Level REPL.") (rep)) - (with-simple-restart - (restart-debugger "Go back to debugger level ~D." break-level) - (rep))) - nil) - (setf quiet nil)))))) + (with-simple-restart + (restart-debugger "Go back to debugger level ~D." break-level) + (rep))) + nil) + (setf quiet nil)))))) (defun tpl-prompt () (typecase *tpl-prompt-hook* @@ -614,11 +614,11 @@ Use special code 0 to cancel this operation.") (function (funcall *tpl-prompt-hook*)) (t (fresh-line) (format t "~A~V,,,'>A " - (if (eq *package* (find-package 'user)) - "" - (package-name *package*)) - (- *tpl-level* *step-level* -1) - "")))) + (if (eq *package* (find-package 'user)) + "" + (package-name *package*)) + (- *tpl-level* *step-level* -1) + "")))) (defun tpl-read (&aux (*read-suppress* nil)) (finish-output) @@ -633,21 +633,21 @@ Use special code 0 to cancel this operation.") (read-char) ;; avoid repeating prompt on successive empty lines: (let ((command (tpl-make-command :newline ""))) - (when command (return command)))) + (when command (return command)))) (:EOF (terpri) (return (tpl-make-command :EOF ""))) (#\: (return (tpl-make-command (read-preserving-whitespace) - (read-line)))) + (read-line)))) (#\? (read-char) (case (peek-char nil *standard-input* nil :EOF) - ((#\space #\tab #\newline #\return :EOF) - (return (tpl-make-command :HELP (read-line)))) - (t - (unread-char #\?) - (return (read-preserving-whitespace))))) + ((#\space #\tab #\newline #\return :EOF) + (return (tpl-make-command :HELP (read-line)))) + (t + (unread-char #\?) + (return (read-preserving-whitespace))))) ;; We use READ-PRESERVING-WHITESPACE because with READ, if an ;; error happens within the reader, and we perform a ":C" or ;; (CONTINUE), the reader will wait for an inexistent #\Newline. @@ -661,14 +661,14 @@ Use special code 0 to cancel this operation.") tpl-command (handler-bind ((error (lambda (condition) - (unless *debug-tpl-commands* - (format t "~&Command aborted.~%Received condition of type: ~A~%~A" - (type-of condition) condition) - (clear-input) - (return-from tpl-command nil) - ) - ) - )) + (unless *debug-tpl-commands* + (format t "~&Command aborted.~%Received condition of type: ~A~%~A" + (type-of condition) condition) + (clear-input) + (return-from tpl-command nil) + ) + ) + )) ,cmd-form ) ) @@ -679,26 +679,26 @@ Use special code 0 to cancel this operation.") (when (setq c (assoc name (cdr commands) :test #'member)) (return))) (cond ((null c) - (if (eq name :newline) ; special handling for Newline. - nil - `(tpl-unknown-command ',name))) - ((eq (third c) :restart) - `(progn - (invoke-restart-interactively ,(second c)))) - ((eq (third c) :eval) - `(,(second c) . ,(tpl-parse-forms line))) - ((eq (third c) :string) - (harden-command `(,(second c) . ,(tpl-parse-strings line)))) - ((eq (third c) :constant) - (harden-command (second c))) - (t - (harden-command `(,(second c) . ,(tpl-parse-forms line t)))))) + (if (eq name :newline) ; special handling for Newline. + nil + `(tpl-unknown-command ',name))) + ((eq (third c) :restart) + `(progn + (invoke-restart-interactively ,(second c)))) + ((eq (third c) :eval) + `(,(second c) . ,(tpl-parse-forms line))) + ((eq (third c) :string) + (harden-command `(,(second c) . ,(tpl-parse-strings line)))) + ((eq (third c) :constant) + (harden-command (second c))) + (t + (harden-command `(,(second c) . ,(tpl-parse-forms line t)))))) (defun tpl-parse-forms (line &optional quote) (with-input-from-string (stream line) (do ((form (read stream nil *eof*) (read stream nil *eof*)) - (list nil)) - ((eq form *eof*) (nreverse list)) + (list nil)) + ((eq form *eof*) (nreverse list)) (push (if quote `',form form) list)))) (defun tpl-parse-strings (line) @@ -710,16 +710,16 @@ Use special code 0 to cancel this operation.") (length (length line))) ((>= i length) (nreverse list)) (cond ((null (setq start (position-if-not space-p line :START i))) - (setq end length)) - ((eql (schar line start) #\") - (multiple-value-bind - (string n) - (read-from-string line t nil :START start) - (push string list) - (setq end n))) - (t - (setq end (or (position-if space-p line :START start) length)) - (push (subseq line start end) list))))) + (setq end length)) + ((eql (schar line start) #\") + (multiple-value-bind + (string n) + (read-from-string line t nil :START start) + (push string list) + (setq end n))) + (t + (setq end (or (position-if space-p line :START start) length)) + (push (subseq line start end) list))))) (defun tpl-print (values) (fresh-line) @@ -773,11 +773,11 @@ Use special code 0 to cancel this operation.") (defun tpl-disassemble-command () (let*((*print-level* 2) - (*print-length* 4) - (*print-pretty* t) - (*print-escape* nil) - (*print-readably* nil) - (functions) (blocks) (variables)) + (*print-length* 4) + (*print-pretty* t) + (*print-escape* nil) + (*print-readably* nil) + (functions) (blocks) (variables)) (unless (si::bc-disassemble (ihs-fun *ihs-current*)) (tpl-print-current) (format t " Function cannot be disassembled.~%")) @@ -785,46 +785,46 @@ Use special code 0 to cancel this operation.") (defun tpl-lambda-expression-command () (let*(;;(*print-level* 2) - ;;(*print-length* 4) - ;;(*print-pretty* t) - ;;(*print-readably* nil) - (function (ihs-fun *ihs-current*)) - (le (function-lambda-expression function))) + ;;(*print-length* 4) + ;;(*print-pretty* t) + ;;(*print-readably* nil) + (function (ihs-fun *ihs-current*)) + (le (function-lambda-expression function))) (if le - (pprint le) - (format t " No source code available for this function.~%")) + (pprint le) + (format t " No source code available for this function.~%")) (values))) (defun reconstruct-bytecodes-lambda-list (data) (declare (si::c-local data)) (let ((output '())) - (dotimes (n (pop data)) ;; required values + (dotimes (n (pop data)) ;; required values (declare (fixnum n)) (push (pop data) output)) - (let ((l (pop data))) ;; optional values + (let ((l (pop data))) ;; optional values (declare (fixnum l)) (unless (zerop l) - (push '&optional output) - (dotimes (n l) - (push (first data) output) - (setf data (cdddr data))))) - (let ((rest (pop data))) ;; &rest value + (push '&optional output) + (dotimes (n l) + (push (first data) output) + (setf data (cdddr data))))) + (let ((rest (pop data))) ;; &rest value (when rest - (push '&rest output) - (push rest output))) + (push '&rest output) + (push rest output))) (let* ((allow-other-keys (pop data))) ;; &keys and &allow-other-keys (unless (eql allow-other-keys 0) - (push '&key output) - (let ((l (pop data))) - (declare (fixnum l)) - (dotimes (n l) - (let* ((key (first data)) - (var (second data))) - (unless (and (keywordp key) (string= key var)) - (setf var (list (list key var)))) - (push var output)))) - (when allow-other-keys - (push '&allow-other-keys output)))) + (push '&key output) + (let ((l (pop data))) + (declare (fixnum l)) + (dotimes (n l) + (let* ((key (first data)) + (var (second data))) + (unless (and (keywordp key) (string= key var)) + (setf var (list (list key var)))) + (push var output)))) + (when allow-other-keys + (push '&allow-other-keys output)))) (nreverse output))) (defun lambda-list-from-annotations (name) @@ -836,10 +836,10 @@ Use special code 0 to cancel this operation.") (cond ((symbolp function) (cond ((or (special-operator-p function) - (macro-function function)) - (lambda-list-from-annotations function)) - (t - (function-lambda-list (fdefinition function))))) + (macro-function function)) + (lambda-list-from-annotations function)) + (t + (function-lambda-list (fdefinition function))))) ((typep function 'generic-function) (values (clos:generic-function-lambda-list function) t)) ;; Use the lambda list from the function definition, if available, @@ -869,56 +869,56 @@ Use special code 0 to cancel this operation.") (defun decode-env-elt (env ndx) (ffi:c-inline (env ndx) (:object :fixnum) :object " - cl_object v = #0; - cl_index ndx = #1; - typedef struct ecl_var_debug_info *pinfo; - pinfo d = (pinfo)(v->vector.self.t[1]) + ndx; - cl_object name = make_constant_base_string(d->name); - void *value = (void*)(v->vector.self.t[2+ndx]); - cl_object output; - switch (d->type) { - case _ecl_object_loc: - output = *((cl_object*)value); - break; - case _ecl_fixnum_loc: { - cl_fixnum *p = (cl_fixnum*)value; - output = ecl_make_integer(*p); - break; - } - case _ecl_float_loc: { - float *p = (float*)value; - output = ecl_make_single_float(*p); - break; - } - case _ecl_double_loc: { - double *p = (double*)value; - output = ecl_make_double_float(*p); - break; - } + cl_object v = #0; + cl_index ndx = #1; + typedef struct ecl_var_debug_info *pinfo; + pinfo d = (pinfo)(v->vector.self.t[1]) + ndx; + cl_object name = make_constant_base_string(d->name); + void *value = (void*)(v->vector.self.t[2+ndx]); + cl_object output; + switch (d->type) { + case _ecl_object_loc: + output = *((cl_object*)value); + break; + case _ecl_fixnum_loc: { + cl_fixnum *p = (cl_fixnum*)value; + output = ecl_make_integer(*p); + break; + } + case _ecl_float_loc: { + float *p = (float*)value; + output = ecl_make_single_float(*p); + break; + } + case _ecl_double_loc: { + double *p = (double*)value; + output = ecl_make_double_float(*p); + break; + } #ifdef ECL_SSE2 - case _ecl_int_sse_pack_loc: { - __m128i *p = (__m128i*)value; - output = ecl_make_int_sse_pack(_mm_loadu_si128(p)); - break; - } - case _ecl_float_sse_pack_loc: { - __m128 *p = (__m128*)value; - output = ecl_make_float_sse_pack(_mm_loadu_ps((float*)p)); - break; - } - case _ecl_double_sse_pack_loc: { - __m128d *p = (__m128d*)value; - output = ecl_make_double_sse_pack(_mm_loadu_pd((double*)p)); - break; - } + case _ecl_int_sse_pack_loc: { + __m128i *p = (__m128i*)value; + output = ecl_make_int_sse_pack(_mm_loadu_si128(p)); + break; + } + case _ecl_float_sse_pack_loc: { + __m128 *p = (__m128*)value; + output = ecl_make_float_sse_pack(_mm_loadu_ps((float*)p)); + break; + } + case _ecl_double_sse_pack_loc: { + __m128d *p = (__m128d*)value; + output = ecl_make_double_sse_pack(_mm_loadu_pd((double*)p)); + break; + } #endif - default: { - ecl_base_char *p = (ecl_base_char*)value; - output = ECL_CODE_CHAR(*p); - break; - } - } - @(return) = CONS(name,output); + default: { + ecl_base_char *p = (ecl_base_char*)value; + output = ECL_CODE_CHAR(*p); + break; + } + } + @(return) = CONS(name,output); " :one-liner nil)) (defun decode-ihs-env (*break-env*) @@ -974,7 +974,7 @@ Use special code 0 to cancel this operation.") (local-variables '()) (special-variables '()) (restarts '()) - record0 record1) + record0 record1) (dolist (record (decode-ihs-env (ihs-env ihs-index))) (cond ((atom record) (push (compiled-function-name record) functions)) @@ -1014,10 +1014,10 @@ Use special code 0 to cancel this operation.") (defun tpl-variables-command (&optional no-values) (let*((*print-level* 2) - (*print-length* 4) - (*print-pretty* t) - (*print-escape* nil) - (*print-readably* nil)) + (*print-length* 4) + (*print-pretty* t) + (*print-escape* nil) + (*print-readably* nil)) (multiple-value-bind (local-variables special-variables functions blocks restarts) (ihs-environment *ihs-current*) (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions) @@ -1036,91 +1036,91 @@ Use special code 0 to cancel this operation.") (when (symbolp var-name) (setq var-name (symbol-name var-name))) (let ((val-pair (assoc var-name (decode-ihs-env *break-env*) - :test #'(lambda (s1 s2) - (when (symbolp s2) (setq s2 (symbol-name s2))) - (if (stringp s2) - (string-equal s1 s2) - nil))))) + :test #'(lambda (s1 s2) + (when (symbolp s2) (setq s2 (symbol-name s2))) + (if (stringp s2) + (string-equal s1 s2) + nil))))) (when val-pair ;;(format t "~&In tpl-inspect-command: val-pair = ~S~%" val-pair) (let ((val (cdr val-pair))) - (inspect val))))) + (inspect val))))) (defun tpl-bds-command (&optional var) (if var (do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi)) - (last (frs-bds (1+ *frs-top*)))) - ((> bi last) - (format t "Variable not found.~%") - (values)) + (last (frs-bds (1+ *frs-top*)))) + ((> bi last) + (format t "Variable not found.~%") + (values)) (when (eq (bds-var bi) var) - (return (let ((val (bds-val bi))) - (if (eq val si::unbound) "" val))))) + (return (let ((val (bds-val bi))) + (if (eq val si::unbound) "" val))))) (do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi)) - (last (frs-bds (1+ *frs-top*))) - (fi *frs-base*) - (*print-level* 2) - (*print-length* 4) - (*print-pretty* t)) - ((> bi last) (values)) + (last (frs-bds (1+ *frs-top*))) + (fi *frs-base*) + (*print-level* 2) + (*print-length* 4) + (*print-pretty* t)) + ((> bi last) (values)) (do () - ((or (> fi *frs-top*) (>= (frs-bds fi) bi))) - (print-frs fi) - (incf fi)) + ((or (> fi *frs-top*) (>= (frs-bds fi) bi))) + (print-frs fi) + (incf fi)) (format t "BDS[~d]: ~s = ~s~%" - bi (bds-var bi) - (let ((val (bds-val bi))) - (if (eq val si::unbound) "" val)))))) + bi (bds-var bi) + (let ((val (bds-val bi))) + (if (eq val si::unbound) "" val)))))) (defun tpl-backtrace (&optional n) - (let ((*print-pretty* nil) ;; because CLOS allows (setf foo) as function names - (base *ihs-base*) - (top *ihs-top*)) + (let ((*print-pretty* nil) ;; because CLOS allows (setf foo) as function names + (base *ihs-base*) + (top *ihs-top*)) (format t "~&Backtrace:~%") (if (null n) - (do ((i top (si::ihs-prev i)) - ;;(b nil t) - ) - ((< i base)) - (when (ihs-visible i) - (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)) - (*print-readably* nil) - (func-name (ihs-fname i))) - ;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB - (format t " > ~S" func-name) - (when (eq func-name 'si::bytecodes) - (format t " [Evaluation of: ~S]" - (function-lambda-expression (ihs-fun i)))) - (terpri) - ))) - (progn - (if (eq t n) - (setq base 0) - (progn - (unless (integerp n) - (error "Argument to command :backtrace must be an integer or t.")) - (setq top *ihs-current*) - ) - ) - (do ((i top (si::ihs-prev i)) - ;;(b nil t) - (j 0 (1+ j)) - (max (if (eq t n) *ihs-top* n)) - ) - ((or (< i base) (>= j max)) - (when (zerop i) (format t " > ---end-of-stack---~%")) - ) - (when (or (ihs-visible i) (eq t n)) - (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)) - (*print-readably* nil) - (func-name (ihs-fname i))) - ;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB - (format t " > ~S" (ihs-fname i)) - (when (eq func-name 'si::bytecodes) + (do ((i top (si::ihs-prev i)) + ;;(b nil t) + ) + ((< i base)) + (when (ihs-visible i) + (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)) + (*print-readably* nil) + (func-name (ihs-fname i))) + ;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB + (format t " > ~S" func-name) + (when (eq func-name 'si::bytecodes) (format t " [Evaluation of: ~S]" (function-lambda-expression (ihs-fun i)))) - (terpri) - )))) + (terpri) + ))) + (progn + (if (eq t n) + (setq base 0) + (progn + (unless (integerp n) + (error "Argument to command :backtrace must be an integer or t.")) + (setq top *ihs-current*) + ) + ) + (do ((i top (si::ihs-prev i)) + ;;(b nil t) + (j 0 (1+ j)) + (max (if (eq t n) *ihs-top* n)) + ) + ((or (< i base) (>= j max)) + (when (zerop i) (format t " > ---end-of-stack---~%")) + ) + (when (or (ihs-visible i) (eq t n)) + (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)) + (*print-readably* nil) + (func-name (ihs-fname i))) + ;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB + (format t " > ~S" (ihs-fname i)) + (when (eq func-name 'si::bytecodes) + (format t " [Evaluation of: ~S]" + (function-lambda-expression (ihs-fun i)))) + (terpri) + )))) ) (terpri)) (values)) @@ -1133,16 +1133,16 @@ Use special code 0 to cancel this operation.") (k n (1- k))) ((= k 0) (values)) (let*((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*))) - (*print-level* 2) - (*print-length* 4) - (*print-pretty* t)) - (do () ((or (> j *frs-top*) (> (frs-ihs j) i))) - (print-frs j) - (incf j))))) + (*print-level* 2) + (*print-length* 4) + (*print-pretty* t)) + (do () ((or (> j *frs-top*) (> (frs-ihs j) i))) + (print-frs j) + (incf j))))) (defun print-frs (i) (format *debug-io* " FRS[~d]: ---> IHS[~d],BDS[~d]~%" - i (frs-ihs i) (frs-bds i))) + i (frs-ihs i) (frs-bds i))) (defun break-where () (if (<= *tpl-level* 0) @@ -1152,7 +1152,7 @@ Use special code 0 to cancel this operation.") (defun tpl-print-current () (let ((*print-readably* nil) - (name (ihs-fname *ihs-current*))) + (name (ihs-fname *ihs-current*))) (format t "~&Broken at ~:@(~S~)." name) (when (eq name 'si::bytecodes) (format t " [Evaluation of: ~S]" @@ -1163,9 +1163,9 @@ Use special code 0 to cancel this operation.") (when (and (symbolp fun) (fboundp fun)) (setf fun (fdefinition fun))) (multiple-value-bind (file position) - (ext:compiled-function-file fun) + (ext:compiled-function-file fun) (when file - (format t " File: ~S (Position #~D)~%" file position)))) + (format t " File: ~S (Position #~D)~%" file position)))) (values)) (defun tpl-hide (fname) @@ -1177,12 +1177,12 @@ Use special code 0 to cancel this operation.") (defun tpl-unhide (fname) (setq *break-hidden-functions* - (delete fname *break-hidden-functions* :test #'eq)) + (delete fname *break-hidden-functions* :test #'eq)) (values)) (defun tpl-unhide-package (package) (setq *break-hidden-packages* - (delete (find-package package) *break-hidden-packages* :test #'eq)) + (delete (find-package package) *break-hidden-packages* :test #'eq)) (values)) (defun tpl-unhide-all () @@ -1202,27 +1202,27 @@ Use special code 0 to cancel this operation.") (let ((fname (ihs-fname i))) #+clos (when (and (consp fname) (eq 'SETF (car fname))) - (setq fname (second fname))) + (setq fname (second fname))) (or (eq fname 'EVAL) - (eq fname 'BYTECODES) - (and (not (member (symbol-package fname) *break-hidden-packages* - :TEST #'eq)) - (not (null fname)) - (not (member fname *break-hidden-functions* :TEST #'eq)))))) + (eq fname 'BYTECODES) + (and (not (member (symbol-package fname) *break-hidden-packages* + :TEST #'eq)) + (not (null fname)) + (not (member fname *break-hidden-functions* :TEST #'eq)))))) (defun ihs-fname (i) (let ((function (ihs-fun i))) (cond ((symbolp function) function) ((compiled-function-p function) (or (compiled-function-name function) 'lambda)) - #+clos - ((si:instancep function) (slot-value function 'name)) + #+clos + ((si:instancep function) (slot-value function 'name)) (t :zombi)))) (defun set-current-ihs () (do ((i *ihs-current* (si::ihs-prev i))) ((or (and (ihs-visible i) (setq *ihs-current* i)) - (<= i *ihs-base*)))) + (<= i *ihs-base*)))) (set-break-env)) (defun set-break-env () @@ -1233,18 +1233,18 @@ Use special code 0 to cancel this operation.") ((< ihs *ihs-base*) (return nil)) (when (and (or unrestricted (ihs-visible ihs)) - (search (string string) (symbol-name (ihs-fname ihs)) - :test #'char-equal)) + (search (string string) (symbol-name (ihs-fname ihs)) + :test #'char-equal)) (return ihs)))) (defun tpl-backward-search (string) (let ((new-ihs (ihs-search string nil *ihs-current*))) (cond (new-ihs - (setf *ihs-current* new-ihs) - (set-current-ihs) - (tpl-print-current)) - (t - (format *debug-io* "Search for ~a failed.~%" string))) + (setf *ihs-current* new-ihs) + (set-current-ihs) + (tpl-print-current)) + (t + (format *debug-io* "Search for ~a failed.~%" string))) (values))) (defun tpl-forward-search (string) @@ -1252,8 +1252,8 @@ Use special code 0 to cancel this operation.") ((> ihs *ihs-top*) (format *debug-io* "Search for ~a failed.~%" string)) (when (and (ihs-visible ihs) - (search string (symbol-name (ihs-fname ihs)) - :test #'char-equal)) + (search string (symbol-name (ihs-fname ihs)) + :test #'char-equal)) (setq *ihs-current* ihs) (set-current-ihs) (tpl-print-current) @@ -1293,26 +1293,26 @@ Use special code 0 to cancel this operation.") (defun tpl-help-command (&optional topic) (cond ((null topic) - (dolist (commands *tpl-commands*) - (format t "~%~A:~%" (car commands)) - (dolist (c (cdr commands)) - (when (fourth c) - (format t "~A.~%" (fourth c)))))) - ((or (stringp topic) (symbolp topic)) - (let (c) - (setq topic (intern (string topic) (find-package 'keyword))) - (dolist (commands *tpl-commands*) - (when (setq c (assoc topic (cdr commands) :test #'member)) - (return))) - (cond ((null (fifth c)) - (format t "No such help topic: ~s~%" - (string topic))) - (t - (terpri) - (format t (fifth c)) - (terpri))))) - (t - (format t "Not a valid help topic: ~s~%" topic))) + (dolist (commands *tpl-commands*) + (format t "~%~A:~%" (car commands)) + (dolist (c (cdr commands)) + (when (fourth c) + (format t "~A.~%" (fourth c)))))) + ((or (stringp topic) (symbolp topic)) + (let (c) + (setq topic (intern (string topic) (find-package 'keyword))) + (dolist (commands *tpl-commands*) + (when (setq c (assoc topic (cdr commands) :test #'member)) + (return))) + (cond ((null (fifth c)) + (format t "No such help topic: ~s~%" + (string topic))) + (t + (terpri) + (format t (fifth c)) + (terpri))))) + (t + (format t "Not a valid help topic: ~s~%" topic))) (values)) (defun tpl-help-stack-command () @@ -1320,22 +1320,22 @@ Use special code 0 to cancel this operation.") Use the following functions to directly access ECL stacks. Invocation History Stack: -(sys:IHS-TOP) Returns the index of the TOP of the IHS. -(SYS:IHS-FUN i) Returns the function of the i-th entity in IHS. +(sys:IHS-TOP) Returns the index of the TOP of the IHS. +(SYS:IHS-FUN i) Returns the function of the i-th entity in IHS. (SYS:IHS-ENV i) (SYS:IHS-PREV i) (SYS:IHS-NEXT i) Frame (catch, block) Stack: -(sys:FRS-TOP) Returns the index of the TOP of the FRS. -(SYS:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. -(SYS:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. +(sys:FRS-TOP) Returns the index of the TOP of the FRS. +(SYS:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. +(SYS:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. (SYS:FRS-TAG i) Binding Stack: -(sys:BDS-TOP) Returns the index of the TOP of the BDS. -(SYS:BDS-VAR i) Returns the symbol of the i-th entity in BDS. -(SYS:BDS-VAL i) Returns the value of the i-th entity in BDS. +(sys:BDS-TOP) Returns the index of the TOP of the BDS. +(SYS:BDS-VAR i) Returns the symbol of the i-th entity in BDS. +(SYS:BDS-VAL i) Returns the value of the i-th entity in BDS. Note that these functions are named by external symbols in the SYSTEM package." @@ -1343,25 +1343,25 @@ package." (defun compute-restart-commands (condition &key display) (let ((restarts (compute-restarts condition)) - (restart-commands (list "Restart commands"))) + (restart-commands (list "Restart commands"))) (when display (format display (if restarts - "~&Available restarts:~2%" - "~&No restarts available.~%"))) + "~&Available restarts:~2%" + "~&No restarts available.~%"))) (loop for restart in restarts and i from 1 do (let ((user-command (format nil "r~D" i)) - (name (format nil "~@[(~A)~]" (restart-name restart))) - (helpstring (princ-to-string restart))) - (push (list - (list (intern (string-upcase user-command) :keyword)) - restart :restart - (format nil ":~A~16T~A~24T~A" user-command helpstring name) - (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command) + (name (format nil "~@[(~A)~]" (restart-name restart))) + (helpstring (princ-to-string restart))) + (push (list + (list (intern (string-upcase user-command) :keyword)) + restart :restart + (format nil ":~A~16T~A~24T~A" user-command helpstring name) + (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command) "[Restart command]" name helpstring)) - restart-commands) - (when display - (format display "~D. ~A ~A~%" i name restart)))) + restart-commands) + (when display + (format display "~D. ~A ~A~%" i name restart)))) (when display (terpri display)) (nreverse restart-commands))) @@ -1382,16 +1382,16 @@ package." #+threads (progn (format *error-output* - "~&Excessive debugger depth! Probable infinite recursion!~%~ + "~&Excessive debugger depth! Probable infinite recursion!~%~ Quitting process: ~A.~%" mp:*current-process*) (when (< (+ *default-debugger-maximum-depth* 3) *break-level*) - ;; we tried to be polite but it does not seem to work. - (quit -1)) + ;; we tried to be polite but it does not seem to work. + (quit -1)) (exit-process)) #-threads (progn (format *error-output* - "~&Excessive debugger depth! Probable infinite recursion!~%~ + "~&Excessive debugger depth! Probable infinite recursion!~%~ Quitting.~%") (quit -1)))) @@ -1426,13 +1426,13 @@ package." (let* ((*standard-input* *debug-io*) (*standard-output* *debug-io*) ;;(*tpl-prompt-hook* "[dbg] ") - (*print-readably* nil) + (*print-readably* nil) (*print-pretty* nil) (*print-circle* t) - (*print-length* 2) + (*print-length* 2) (*readtable* (or *break-readtable* *readtable*)) (*break-message* (format nil "~&Condition of type: ~A~%~A~%" - (type-of condition) condition)) + (type-of condition) condition)) (*break-level* (1+ *break-level*)) (break-level *break-level*) (*break-env* nil)) @@ -1443,7 +1443,7 @@ package." ;; As of ECL 9.4.1 making a normal function return from the debugger ;; seems to be a very bad idea! Basically, it dumps core... (when (listen *debug-io*) - (clear-input *debug-io*)) + (clear-input *debug-io*)) ;; Like in SBCL, the error message is output through *error-output* ;; The rest of the interaction is performed through *debug-io* (finish-output) @@ -1451,15 +1451,15 @@ package." (terpri *error-output*) (princ *break-message* *error-output*) (loop - ;; Here we show a list of restarts and invoke the toplevel with - ;; an extended set of commands which includes invoking the associated - ;; restarts. - (let* ((restart-commands (compute-restart-commands condition :display t)) - (debug-commands - ;;(adjoin restart-commands (adjoin break-commands *tpl-commands*)) - (update-debug-commands restart-commands) - )) - (tpl :commands debug-commands)))))) + ;; Here we show a list of restarts and invoke the toplevel with + ;; an extended set of commands which includes invoking the associated + ;; restarts. + (let* ((restart-commands (compute-restart-commands condition :display t)) + (debug-commands + ;;(adjoin restart-commands (adjoin break-commands *tpl-commands*)) + (update-debug-commands restart-commands) + )) + (tpl :commands debug-commands)))))) (defun invoke-debugger (condition) ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not @@ -1502,7 +1502,7 @@ value." (handler-bind ((serious-condition (if err-value-p #'(lambda (condition) - (declare (ignore condition)) + (declare (ignore condition)) (return-from safe-eval err-value)) #'invoke-debugger))) (setf output (si::eval-with-env form env) diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 8551fcbc1..d2b89dbfd 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -26,20 +26,20 @@ return values. The keywords allow to control when and how tracing is performed. The possible keywords are: - :BREAK a breakpoint is entered after printing the entry trace - information, but before applying the traced function to its - arguments, if form evaluates to non-nil - :BREAK-AFTER like :BREAK but the breakpoint is entered after the function - has been executed and the exit trace information has been - printed and before control returns - :COND-BEFORE information is printed upon entry if form evaluates to non-nil - :COND-AFTER information is printed upon exit if form evaluates to non-nil - :COND specifies a single condition for both entry and exit - :PRINT prints the values of the forms in the list upon entry. - They are preceeded by a backslash (\\) - :PRINT-AFTER prints the values of the forms in the list upon exit from the - function. They are preceeded by a backslash (\\) - :STEP turns on the stepping facility + :BREAK a breakpoint is entered after printing the entry trace + information, but before applying the traced function to its + arguments, if form evaluates to non-nil + :BREAK-AFTER like :BREAK but the breakpoint is entered after the function + has been executed and the exit trace information has been + printed and before control returns + :COND-BEFORE information is printed upon entry if form evaluates to non-nil + :COND-AFTER information is printed upon exit if form evaluates to non-nil + :COND specifies a single condition for both entry and exit + :PRINT prints the values of the forms in the list upon entry. + They are preceeded by a backslash (\\) + :PRINT-AFTER prints the values of the forms in the list upon exit from the + function. They are preceeded by a backslash (\\) + :STEP turns on the stepping facility Forms can refer to the list of arguments of the function through the variable SI::ARGS." @@ -64,29 +64,29 @@ all functions." (defun trace-one (spec) (let* (break exitbreak (entrycond t) (exitcond t) entry exit - step (barfp t) fname oldf) + step (barfp t) fname oldf) (cond ((si::valid-function-name-p spec) - (setq fname spec)) + (setq fname spec)) ((not (si::proper-list-p spec)) (error "Not a valid argument to TRACE: ~S" spec)) - ((si::valid-function-name-p (first spec)) - (setq fname (first spec)) - (do ((specs (cdr spec) (cdr specs))) - ((null specs)) - (case (car specs) - (:break (setq barfp specs specs (cdr specs) break (car specs))) - (:break-after (setq barfp specs specs (cdr specs) exitbreak (car specs))) - (:step (setq step t)) - (:cond (setq barfp specs specs (cdr specs)) - (setq exitcond (setq entrycond (car specs)))) - (:cond-before (setq barfp specs specs (cdr specs) entrycond (car specs))) - (:cond-after (setq barfp specs specs (cdr specs) exitcond (car specs))) - (:print (setq barfp specs specs (cdr specs) entry (car specs))) - (:print-after (setq barfp specs specs (cdr specs) exit (car specs))) - (t (error "Meaningless TRACE keyword: ~S" (car specs)))) - (unless barfp (error "Parameter missing")))) - ((si::proper-list-p (first spec)) - (let (results) + ((si::valid-function-name-p (first spec)) + (setq fname (first spec)) + (do ((specs (cdr spec) (cdr specs))) + ((null specs)) + (case (car specs) + (:break (setq barfp specs specs (cdr specs) break (car specs))) + (:break-after (setq barfp specs specs (cdr specs) exitbreak (car specs))) + (:step (setq step t)) + (:cond (setq barfp specs specs (cdr specs)) + (setq exitcond (setq entrycond (car specs)))) + (:cond-before (setq barfp specs specs (cdr specs) entrycond (car specs))) + (:cond-after (setq barfp specs specs (cdr specs) exitcond (car specs))) + (:print (setq barfp specs specs (cdr specs) entry (car specs))) + (:print-after (setq barfp specs specs (cdr specs) exit (car specs))) + (t (error "Meaningless TRACE keyword: ~S" (car specs)))) + (unless barfp (error "Parameter missing")))) + ((si::proper-list-p (first spec)) + (let (results) (dolist (fname (first spec)) (push (trace-one (list* fname (rest spec))) results)) (return-from trace-one (nreverse results)))) @@ -97,11 +97,11 @@ all functions." (return-from trace-one nil)) (when (symbolp fname) (when (special-operator-p fname) - (warn "Unable to trace special form ~S." fname) - (return-from trace-one nil)) + (warn "Unable to trace special form ~S." fname) + (return-from trace-one nil)) (when (macro-function fname) - (warn "Unable to trace macro ~S." fname) - (return-from trace-one nil))) + (warn "Unable to trace macro ~S." fname) + (return-from trace-one nil))) (let ((record (trace-record fname))) (when record (cond ((traced-and-redefined-p record) @@ -112,37 +112,37 @@ all functions." (setq oldf (fdefinition fname)) (eval `(defun ,fname (&rest args) - (let* (values (*trace-level* (1+ *trace-level*))) - (if *inside-trace* - (setq values (multiple-value-list (apply ',oldf args))) - (let ((*inside-trace* t)) - ,@(when entrycond - (if (eq t entrycond) - `((trace-print 'ENTER ',fname args ,@entry)) - `((when ,entrycond - (trace-print 'ENTER ',fname args ,@entry))))) - ,@(when break - `((when ,break (let (*inside-trace*) - (break "tracing ~S" ',fname))))) - (setq values - (let (*inside-trace*) - (multiple-value-list - (apply ',oldf args) - #+nil - ,(if step - `(let (*step-quit*) - (applyhook ',oldf args #'stepper nil)) - `(apply ',oldf args))))) - ,@(when exitcond - (if (eq t exitcond) - `((trace-print 'EXIT ',fname values ,@exit)) - `((when ,exitcond - (trace-print 'EXIT ',fname values ,@exit))))) - ,@(when exitbreak - `((when ,exitbreak - (let (*inside-trace*) - (break "after tracing ~S" ',fname))))))) - (values-list values)))) + (let* (values (*trace-level* (1+ *trace-level*))) + (if *inside-trace* + (setq values (multiple-value-list (apply ',oldf args))) + (let ((*inside-trace* t)) + ,@(when entrycond + (if (eq t entrycond) + `((trace-print 'ENTER ',fname args ,@entry)) + `((when ,entrycond + (trace-print 'ENTER ',fname args ,@entry))))) + ,@(when break + `((when ,break (let (*inside-trace*) + (break "tracing ~S" ',fname))))) + (setq values + (let (*inside-trace*) + (multiple-value-list + (apply ',oldf args) + #+nil + ,(if step + `(let (*step-quit*) + (applyhook ',oldf args #'stepper nil)) + `(apply ',oldf args))))) + ,@(when exitcond + (if (eq t exitcond) + `((trace-print 'EXIT ',fname values ,@exit)) + `((when ,exitcond + (trace-print 'EXIT ',fname values ,@exit))))) + ,@(when exitbreak + `((when ,exitbreak + (let (*inside-trace*) + (break "after tracing ~S" ',fname))))))) + (values-list values)))) (add-to-trace-list fname oldf) (list fname))) @@ -234,38 +234,38 @@ all functions." (defconstant step-commands `("Stepper commands" ((:newline) (step-next) :constant - "newline Advance to the next form" - "newline [Stepper command]~@ - ~@ - Step to next form.~%") + "newline Advance to the next form" + "newline [Stepper command]~@ + ~@ + Step to next form.~%") ((:s :skip) step-skip nil - ":s(kip) Skip current form or until function" - ":skip &optional arg [Stepper command]~@ - :s &optional arg [Abbreviation]~@ - ~@ - Continue evaluation without stepping. Without argument, resume - stepping after the current form. With numeric argument (n), - resume stepping at the n-th level above. With function name, resume - when given function is called.~%") + ":s(kip) Skip current form or until function" + ":skip &optional arg [Stepper command]~@ + :s &optional arg [Abbreviation]~@ + ~@ + Continue evaluation without stepping. Without argument, resume + stepping after the current form. With numeric argument (n), + resume stepping at the n-th level above. With function name, resume + when given function is called.~%") ((:pr :print) (step-print) :constant - ":pr(int) Pretty print current form" - ":print [Stepper command]~@ - :p [Abbreviation]~@ - ~@ - Pretty print current form.~%") + ":pr(int) Pretty print current form" + ":print [Stepper command]~@ + :p [Abbreviation]~@ + ~@ + Pretty print current form.~%") ((:form) *step-form* :constant - ":form Current form" - ":form [Stepper command]~@ - ~@ - Return the current form. Nothing is done, but the current form~@ - is returned as the value of this command. As a consequence,~@ - it is printed by the top level in the usual way and saved in~@ - the variable *. The main purpose of this command is to allow~@ - the current form to be examined further by accessing *.~%") + ":form Current form" + ":form [Stepper command]~@ + ~@ + Return the current form. Nothing is done, but the current form~@ + is returned as the value of this command. As a consequence,~@ + it is printed by the top level in the usual way and saved in~@ + the variable *. The main purpose of this command is to allow~@ + the current form to be examined further by accessing *.~%") ((:x :exit) (step-quit) :constant - ":x or :exit Finish evaluation and exit stepper" - ":exit [Stepper command]~@ - :x [Abbreviation]~@ + ":x or :exit Finish evaluation and exit stepper" + ":exit [Stepper command]~@ + :x [Abbreviation]~@ ~@ Finish evaluation without stepping.~%") )) @@ -278,41 +278,41 @@ for Stepper mode commands." (defun step* (form) (let* ((*step-action* t) - (*step-level* 0) - (*step-functions* (make-hash-table :size 128 :test 'eq))) + (*step-level* 0) + (*step-functions* (make-hash-table :size 128 :test 'eq))) (catch *step-tag* (si:eval-with-env form nil t)))) (defun steppable-function (form) (let ((*step-action* nil)) (or (gethash form *step-functions*) - (multiple-value-bind (f env name) - (function-lambda-expression form) - (if (and (not (trace-record name)) f) - (setf (gethash form *step-functions*) - (eval-with-env `(function ,f) env t)) - form))))) + (multiple-value-bind (f env name) + (function-lambda-expression form) + (if (and (not (trace-record name)) f) + (setf (gethash form *step-functions*) + (eval-with-env `(function ,f) env t)) + form))))) (defun stepper (form) (when (typep form '(or symbol function)) (return-from stepper (steppable-function (coerce form 'function)))) (let* ((*step-form* form) - (*step-action* nil) - (indent (min (* *tpl-level* 2) 20)) - prompt) + (*step-action* nil) + (indent (min (* *tpl-level* 2) 20)) + prompt) (setq prompt - #'(lambda () - (format *debug-io* "~VT" indent) - (write form :stream *debug-io* :pretty nil - :level 2 :length 2) - (princ #\space *debug-io*) - (princ #\- *debug-io*))) + #'(lambda () + (format *debug-io* "~VT" indent) + (write form :stream *debug-io* :pretty nil + :level 2 :length 2) + (princ #\space *debug-io*) + (princ #\- *debug-io*))) (when (catch *step-tag* - (tpl :quiet t - :commands (adjoin step-commands - (adjoin break-commands *tpl-commands*)) - :broken-at 'stepper - :prompt-hook prompt)) + (tpl :quiet t + :commands (adjoin step-commands + (adjoin break-commands *tpl-commands*)) + :broken-at 'stepper + :prompt-hook prompt)) (throw *step-tag* t)))) (defun step-next () diff --git a/src/lsp/util.lsp b/src/lsp/util.lsp index fbf6743fd..4b1027d7f 100644 --- a/src/lsp/util.lsp +++ b/src/lsp/util.lsp @@ -3,15 +3,15 @@ (in-package "COMPILER") (defvar file-list '( "defmacro.lsp" "evalmacros.lsp" "top.lsp" - "module.lsp" "predlib.lsp" "setf.lsp" - "arraylib.lsp" "assert.lsp" "defstruct.lsp" - "describe.lsp" "iolib.lsp" "listlib.lsp" - "mislib.lsp" "numlib.lsp" "packlib.lsp" - "seq.lsp" "seqlib.lsp" "trace.lsp" - "thread.lsp" "loop.lsp")) + "module.lsp" "predlib.lsp" "setf.lsp" + "arraylib.lsp" "assert.lsp" "defstruct.lsp" + "describe.lsp" "iolib.lsp" "listlib.lsp" + "mislib.lsp" "numlib.lsp" "packlib.lsp" + "seq.lsp" "seqlib.lsp" "trace.lsp" + "thread.lsp" "loop.lsp")) (load "../cmp/make-declare.lsp") (dolist (file file-list) - (sys::proclaim-file file "/tmp/try.lsp")) + (sys::proclaim-file file "/tmp/try.lsp")) diff --git a/src/new-cmp/cmpblock.lsp b/src/new-cmp/cmpblock.lsp index 5fdb8f3b5..570b0a4d9 100644 --- a/src/new-cmp/cmpblock.lsp +++ b/src/new-cmp/cmpblock.lsp @@ -29,10 +29,10 @@ (unless (symbolp block-name) (cmperr "The block name ~s is not a symbol." block-name)) (let* ((blk-var (make-var :name (gensym (symbol-name block-name)) :kind 'LEXICAL)) - (cleanup-form (c1frame-pop blk-var)) + (cleanup-form (c1frame-pop blk-var)) (*cmp-env* (cmp-env-copy *cmp-env*)) (exit (make-tag :name (gensym "BLOCK") :label (next-label))) - (blk (make-blk :var blk-var :name block-name :destination destination + (blk (make-blk :var blk-var :name block-name :destination destination :exit exit))) (cmp-env-register-var blk-var *cmp-env*) (cmp-env-register-block blk *cmp-env*) @@ -60,19 +60,19 @@ (unless (symbolp name) (cmperr "The block name ~s is not a symbol." name)) (multiple-value-bind (blk ccb clb unw) - (cmp-env-search-block name) + (cmp-env-search-block name) (unless blk - (cmperr "The block ~s is undefined." name)) + (cmperr "The block ~s is undefined." name)) (let* ((destination (blk-destination blk)) - (var (blk-var blk)) - output) - (cond (ccb (setf (blk-ref-ccb blk) t + (var (blk-var blk)) + output) + (cond (ccb (setf (blk-ref-ccb blk) t (var-kind var) 'CLOSURE - (var-ref-ccb var) T)) - (clb (setf (blk-ref-clb blk) t + (var-ref-ccb var) T)) + (clb (setf (blk-ref-clb blk) t (var-ref-clb var) t (var-kind var) 'LEXICAL)) - (unw (setf type 'UNWIND-PROTECT) + (unw (setf type 'UNWIND-PROTECT) (unless (var-kind var) (setf (var-kind var) :OBJECT)))) (if (or ccb clb unw) @@ -89,5 +89,5 @@ cleanup postfix (c1jmp exit-tag)))))) - (incf (blk-ref blk)) + (incf (blk-ref blk)) output)))) diff --git a/src/new-cmp/cmpc-bind.lsp b/src/new-cmp/cmpc-bind.lsp index b40f4fca2..0a7178260 100644 --- a/src/new-cmp/cmpc-bind.lsp +++ b/src/new-cmp/cmpc-bind.lsp @@ -28,9 +28,9 @@ (CLOSURE (let ((var-loc (var-loc var))) (unless (sys:fixnump var-loc) - ;; first binding: assign location - (setq var-loc (next-env)) - (setf (var-loc var) var-loc)) + ;; first binding: assign location + (setq var-loc (next-env)) + (setf (var-loc var) var-loc)) (wt-nl "cl_object CLV" var-loc "=env" *env-lvl* "=CONS(") (wt-coerce-loc :object loc) (if (zerop var-loc) @@ -40,9 +40,9 @@ (LEXICAL (let ((var-loc (var-loc var))) (unless (consp var-loc) - ;; first binding: assign location - (setq var-loc (next-lex)) - (setf (var-loc var) var-loc)) + ;; first binding: assign location + (setq var-loc (next-lex)) + (setf (var-loc var) var-loc)) (wt-nl) (wt-lex var-loc) (wt "= ") (wt-coerce-loc :object loc) (wt ";")) @@ -51,27 +51,27 @@ (bds-bind loc var)) (t (cond ((not (eq (var-loc var) 'OBJECT)) - ;; already has location (e.g. optional in lambda list) - ;; check they are not the same - (unless (equal (var-loc var) loc) - (wt-nl var "= ") - (wt-coerce-loc (var-rep-type var) loc) - (wt ";"))) - ((and (consp loc) (eql (car loc) 'LCL)) - ;; set location for lambda list requireds - (setf (var-loc var) loc)) - (t - (baboon))) - ))) + ;; already has location (e.g. optional in lambda list) + ;; check they are not the same + (unless (equal (var-loc var) loc) + (wt-nl var "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt ";"))) + ((and (consp loc) (eql (car loc) 'LCL)) + ;; set location for lambda list requireds + (setf (var-loc var) loc)) + (t + (baboon))) + ))) (defun bds-bind (loc var) ;; Optimize the case (let ((*special-var* *special-var*)) ...) (cond ((and (var-p loc) - (member (var-kind loc) '(global special)) - (eq (var-name loc) (var-name var))) - (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) - (t - (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") - (wt-coerce-loc :object loc) - (wt ");"))) + (member (var-kind loc) '(global special)) + (eq (var-name loc) (var-name var))) + (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) + (t + (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") + (wt-coerce-loc :object loc) + (wt ");"))) (wt-comment (var-name var))) diff --git a/src/new-cmp/cmpc-cbk.lsp b/src/new-cmp/cmpc-cbk.lsp index dde61b440..262444ee2 100644 --- a/src/new-cmp/cmpc-cbk.lsp +++ b/src/new-cmp/cmpc-cbk.lsp @@ -17,32 +17,32 @@ (destructuring-bind (name return-type arg-list &rest body) args (let ((arg-types '()) - (arg-type-constants '()) - (arg-variables '()) - (c-name (format nil "ecl_callback_~d" (length *callbacks*))) - (name (if (consp name) (first name) name)) - (call-type (if (consp name) (second name) :cdecl))) + (arg-type-constants '()) + (arg-variables '()) + (c-name (format nil "ecl_callback_~d" (length *callbacks*))) + (name (if (consp name) (first name) name)) + (call-type (if (consp name) (second name) :cdecl))) (dolist (i arg-list) - (unless (consp i) - (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) - (push (first i) arg-variables) - (let ((type (second i))) - (push (second i) arg-types) - (push (if (ffi::foreign-elt-type-p type) - (foreign-elt-type-code type) - (add-object type)) - arg-type-constants))) + (unless (consp i) + (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) + (push (first i) arg-variables) + (let ((type (second i))) + (push (second i) arg-types) + (push (if (ffi::foreign-elt-type-p type) + (foreign-elt-type-code type) + (add-object type)) + arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants) call-type) - *callbacks*) + return-type (reverse arg-types) (reverse arg-type-constants) call-type) + *callbacks*) (c1translate destination `(progn - (defun ,name ,(reverse arg-variables) ,@body) - (si::put-sysprop ',name :callback - (list - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) - :one-liner t))))) + (defun ,name ,(reverse arg-variables) ,@body) + (si::put-sysprop ',name :callback + (list + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name) + :one-liner t))))) ))) (defconstant +foreign-elt-type-codes+ @@ -70,30 +70,30 @@ (cdr x))) (defun t3-defcallback (lisp-name c-name c-name-constant return-type - arg-types arg-type-constants call-type &aux (return-p t)) + arg-types arg-type-constants call-type &aux (return-p t)) (cond ((ffi::foreign-elt-type-p return-type)) - ((member return-type '(nil :void)) - (setf return-p nil)) - ((and (consp return-type) - (member (first return-type) '(* array))) - (setf return-type :pointer-void)) - (t - (cmperr "DEFCALLBACK does not support complex return types such as ~A" - return-type))) + ((member return-type '(nil :void)) + (setf return-p nil)) + ((and (consp return-type) + (member (first return-type) '(* array))) + (setf return-type :pointer-void)) + (t + (cmperr "DEFCALLBACK does not support complex return types such as ~A" + return-type))) (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type))) - (fmod (case call-type - (:cdecl "") - (:stdcall "__stdcall ") - (t (cmperr "DEFCALLBACK does not support ~A as calling convention" - call-type))))) + (fmod (case call-type + (:cdecl "") + (:stdcall "__stdcall ") + (t (cmperr "DEFCALLBACK does not support ~A as calling convention" + call-type))))) (wt-nl1 "static " return-type-name " " fmod c-name "(") (loop for n from 0 - and type in arg-types - with comma = "" - do - (progn - (wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) - (setf comma ","))) + and type in arg-types + with comma = "" + do + (progn + (wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) + (setf comma ","))) (wt ")") (wt-nl1 "{") (when return-p @@ -102,19 +102,19 @@ (wt-nl "cl_object aux;") (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)") (loop for n from 0 - and type in arg-types - and ct in arg-type-constants - do - (if (stringp ct) - (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" + and type in arg-types + and ct in arg-type-constants + do + (if (stringp ct) + (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" n "," ct "));") - (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" + (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" n "," ct "," (ffi:size-of-foreign-type type) "));"))) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") (when return-p (wt-nl "ecl_foreign_data_set_elt(&output," - (foreign-elt-type-code return-type) ",aux);") + (foreign-elt-type-code return-type) ",aux);") (wt-nl "return output;")) (wt-nl1 "}"))) diff --git a/src/new-cmp/cmpc-data.lsp b/src/new-cmp/cmpc-data.lsp index 1f5ef01f0..5636c50f0 100644 --- a/src/new-cmp/cmpc-data.lsp +++ b/src/new-cmp/cmpc-data.lsp @@ -26,8 +26,8 @@ (null (return-from data-dump)) ((or pathname string) (setf stream (open stream :direction :output :if-does-not-exist :create - :if-exists :supersede :external-format :default) - must-close stream)) + :if-exists :supersede :external-format :default) + must-close stream)) (stream)) (si::with-ecl-io-syntax (extract-static-constants stream) @@ -71,7 +71,7 @@ #define VMtemp 0 #define VV NULL ") - (format stream " + (format stream " #define VM ~A #define VMtemp ~A #ifdef ECL_DYNAMIC_VV @@ -101,29 +101,29 @@ static cl_object VV[VM]; ;;; (defun wt-filtered-data (string stream &optional one-liner) (let ((N (length string)) - (wt-data-column 80)) + (wt-data-column 80)) (incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space (format stream (if one-liner "\"" "~%\"")) (dotimes (i N) (decf wt-data-column) (when (< wt-data-column 0) - (format stream "\"~% \"") - (setq wt-data-column 79)) + (format stream "\"~% \"") + (setq wt-data-column 79)) (let ((x (aref string i))) - (cond - ((or (< (char-code x) 32) - (> (char-code x) 127)) - (case x - ; We avoid a trailing backslash+newline because some preprocessors - ; remove them. - (#\Newline (princ "\\n" stream)) - (#\Tab (princ "\\t" stream)) - (t (format stream "\\~3,'0o" (char-code x))))) - ((char= x #\\) - (princ "\\\\" stream)) - ((char= x #\") - (princ "\\\"" stream)) - (t (princ x stream))))) + (cond + ((or (< (char-code x) 32) + (> (char-code x) 127)) + (case x + ; We avoid a trailing backslash+newline because some preprocessors + ; remove them. + (#\Newline (princ "\\n" stream)) + (#\Tab (princ "\\t" stream)) + (t (format stream "\\~3,'0o" (char-code x))))) + ((char= x #\\) + (princ "\\\\" stream)) + ((char= x #\") + (princ "\\\"" stream)) + (t (princ x stream))))) (princ (if one-liner "\"" " \"") stream) string)) @@ -218,7 +218,7 @@ static cl_object VV[VM]; (mapc #'(lambda (record) (let* ((name (first record)) - (c-value (second record))) + (c-value (second record))) (push (cond ((symbolp name) (let* ((value (symbol-value name))) diff --git a/src/new-cmp/cmpc-ffi.lsp b/src/new-cmp/cmpc-ffi.lsp index cb20d4c8a..7d3207420 100644 --- a/src/new-cmp/cmpc-ffi.lsp +++ b/src/new-cmp/cmpc-ffi.lsp @@ -50,11 +50,11 @@ (let ((output (getf +representation-types+ rep-type))) (cond (output (if (eq rep-type :void) nil - (or (first output) - (cmperr "Representation type ~S cannot be coerced to lisp" + (or (first output) + (cmperr "Representation type ~S cannot be coerced to lisp" rep-type)))) - ((lisp-type-p rep-type) rep-type) - (t (cmperr "Unknown representation type ~S" rep-type))))) + ((lisp-type-p rep-type) rep-type) + (t (cmperr "Unknown representation type ~S" rep-type))))) (defun lisp-type->rep-type (type) (cond @@ -65,9 +65,9 @@ type) (t (do ((l +representation-types+ (cddr l))) - ((endp l) :object) + ((endp l) :object) (when (subtypep type (first (second l))) - (return-from lisp-type->rep-type (first l))))))) + (return-from lisp-type->rep-type (first l))))))) (defun rep-type-name (type) (or (second (getf +representation-types+ type)) @@ -95,174 +95,174 @@ (if (atom loc) t (case (first loc) - ((CALL CALL-LOCAL) NIL) - ((C-INLINE) (not (fifth loc))) ; side effects? - (otherwise t)))) + ((CALL CALL-LOCAL) NIL) + ((C-INLINE) (not (fifth loc))) ; side effects? + (otherwise t)))) (defun loc-representation-type (loc) (cond ((member loc '(NIL T)) :object) - ((var-p loc) (var-rep-type loc)) - ((si::fixnump loc) :fixnum) + ((var-p loc) (var-rep-type loc)) + ((si::fixnump loc) :fixnum) ((eq loc 'TRASH) :void) - ((atom loc) :object) - (t - (case (first loc) - (FIXNUM-VALUE :fixnum) - (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) - (DOUBLE-FLOAT-VALUE :double) - (SINGLE-FLOAT-VALUE :float) - (LONG-FLOAT-VALUE :long-double) - (C-INLINE (let ((type (first (second loc)))) + ((atom loc) :object) + (t + (case (first loc) + (FIXNUM-VALUE :fixnum) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) + (DOUBLE-FLOAT-VALUE :double) + (SINGLE-FLOAT-VALUE :float) + (LONG-FLOAT-VALUE :long-double) + (C-INLINE (let ((type (first (second loc)))) (cond ((and (consp type) (eq (first type) 'VALUES)) :object) ((lisp-type-p type) (lisp-type->rep-type type)) (t type)))) - (BIND (var-rep-type (second loc))) - (LCL (lisp-type->rep-type (or (third loc) T))) - (otherwise :object))))) + (BIND (var-rep-type (second loc))) + (LCL (lisp-type->rep-type (or (third loc) T))) + (otherwise :object))))) (defun wt-coerce-loc (dest-rep-type loc) (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) ;(print dest-rep-type) ;(print loc) (let* ((dest-type (rep-type->lisp-type dest-rep-type)) - (loc-type (location-type loc)) - (loc-rep-type (loc-representation-type loc))) + (loc-type (location-type loc)) + (loc-rep-type (loc-representation-type loc))) (labels ((coercion-error () - (cmperr "Unable to coerce lisp object from type (~S,~S)~%~ - to C/C++ type (~S,~S)" - loc-type loc-rep-type dest-type dest-rep-type)) - (ensure-valid-object-type (a-lisp-type) - (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) - (coercion-error)))) + (cmperr "Unable to coerce lisp object from type (~S,~S)~%~ + to C/C++ type (~S,~S)" + loc-type loc-rep-type dest-type dest-rep-type)) + (ensure-valid-object-type (a-lisp-type) + (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) + (coercion-error)))) (when (eq dest-rep-type loc-rep-type) - (wt loc) - (return-from wt-coerce-loc)) + (wt loc) + (return-from wt-coerce-loc)) (case dest-rep-type - ((:byte :unsigned-byte :short :unsigned-short :int :unsigned-int - :long :unsigned-long :fixnum :cl-index) - (case loc-rep-type - (#1=(:byte :unsigned-byte :short :unsigned-short :int :unsigned-int - :long :unsigned-long :fixnum :cl-index - :float :double :long-double) ; number types - (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) - ((:object) - (ensure-valid-object-type dest-type) - (wt (cond ((or (subtypep (location-type loc) 'fixnum) + ((:byte :unsigned-byte :short :unsigned-short :int :unsigned-int + :long :unsigned-long :fixnum :cl-index) + (case loc-rep-type + (#1=(:byte :unsigned-byte :short :unsigned-short :int :unsigned-int + :long :unsigned-long :fixnum :cl-index + :float :double :long-double) ; number types + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt (cond ((or (subtypep (location-type loc) 'fixnum) (policy-assume-no-errors)) - "fix(") - ((member dest-rep-type '(:unsigned-short :unsigned-long :cl-index)) - "ecl_to_unsigned_integer(") - (t - "ecl_to_fixnum(")) - loc ")")) - (otherwise - (coercion-error)))) - ((:char :unsigned-char :wchar) - (case loc-rep-type - ((:char :unsigned-char :wchar) - (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) - ((:object) - (ensure-valid-object-type dest-type) - (wt "ecl_char_code(" loc ")")) - (otherwise - (coercion-error)))) - ((:float :double :long-double) - (case loc-rep-type - (#1# ; number type - (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) - ((:object) - ;; We relax the check a bit, because it is valid in C to coerce - ;; between floats of different types. - (ensure-valid-object-type 'FLOAT) - (wt (ecase dest-rep-type - (:float "ecl_to_float(") - (:double "ecl_to_double(") - (:long-double "ecl_to_long_double(")) - loc ")")) - (otherwise - (coercion-error)))) - ((:bool) - (case loc-rep-type - (#1# ; number type - (wt "1")) - ((:object) - (wt "(" loc ")!=Cnil")) - (otherwise - (coercion-error)))) - ((:object) - (case loc-rep-type - ((:short :int :long) - (wt "ecl_make_integer(" loc ")")) - ((:unsigned-short :unsigned-int :unsigned-long) - (wt "ecl_make_unsigned_integer(" loc ")")) - ((:byte :unsigned-byte :fixnum) - (wt "MAKE_FIXNUM(" loc ")")) - ((:float) - (if (and (consp loc) (eq (first loc) 'SINGLE-FLOAT-VALUE)) - (wt (third loc)) ;; VV index - (wt "ecl_make_singlefloat(" loc ")"))) - ((:double) - (if (and (consp loc) (eq (first loc) 'DOUBLE-FLOAT-VALUE)) - (wt (third loc)) ;; VV index - (wt "ecl_make_doublefloat(" loc ")"))) - ((:long-double) - (if (and (consp loc) (eq (first loc) 'LONG-FLOAT-VALUE)) - (wt (third loc)) ;; VV index - (wt "ecl_make_longfloat(" loc ")"))) - ((:bool) - (wt "((" loc ")?Ct:Cnil)")) - ((:char :unsigned-char :wchar) - (wt "CODE_CHAR(" loc ")")) - ((:cstring) - (wt "ecl_cstring_to_base_string_or_nil(" loc ")")) - ((:pointer-void) - (wt "ecl_make_foreign_data(Cnil, 0, " loc ")")) - (otherwise - (coercion-error)))) - ((:pointer-void) - (case loc-rep-type - ((:object) - ;; Only foreign data types can be coerced to a pointer - (wt "ecl_foreign_data_pointer_safe(" loc ")")) - ((:cstring) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) - ((:cstring) - (coercion-error)) - ((:char*) - (case loc-rep-type - ((:object) - (wt "ecl_base_string_pointer_safe(" loc ")")) - ((:pointer-void) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) + "fix(") + ((member dest-rep-type '(:unsigned-short :unsigned-long :cl-index)) + "ecl_to_unsigned_integer(") + (t + "ecl_to_fixnum(")) + loc ")")) + (otherwise + (coercion-error)))) + ((:char :unsigned-char :wchar) + (case loc-rep-type + ((:char :unsigned-char :wchar) + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt "ecl_char_code(" loc ")")) + (otherwise + (coercion-error)))) + ((:float :double :long-double) + (case loc-rep-type + (#1# ; number type + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + ;; We relax the check a bit, because it is valid in C to coerce + ;; between floats of different types. + (ensure-valid-object-type 'FLOAT) + (wt (ecase dest-rep-type + (:float "ecl_to_float(") + (:double "ecl_to_double(") + (:long-double "ecl_to_long_double(")) + loc ")")) + (otherwise + (coercion-error)))) + ((:bool) + (case loc-rep-type + (#1# ; number type + (wt "1")) + ((:object) + (wt "(" loc ")!=Cnil")) + (otherwise + (coercion-error)))) + ((:object) + (case loc-rep-type + ((:short :int :long) + (wt "ecl_make_integer(" loc ")")) + ((:unsigned-short :unsigned-int :unsigned-long) + (wt "ecl_make_unsigned_integer(" loc ")")) + ((:byte :unsigned-byte :fixnum) + (wt "MAKE_FIXNUM(" loc ")")) + ((:float) + (if (and (consp loc) (eq (first loc) 'SINGLE-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_singlefloat(" loc ")"))) + ((:double) + (if (and (consp loc) (eq (first loc) 'DOUBLE-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_doublefloat(" loc ")"))) + ((:long-double) + (if (and (consp loc) (eq (first loc) 'LONG-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_longfloat(" loc ")"))) + ((:bool) + (wt "((" loc ")?Ct:Cnil)")) + ((:char :unsigned-char :wchar) + (wt "CODE_CHAR(" loc ")")) + ((:cstring) + (wt "ecl_cstring_to_base_string_or_nil(" loc ")")) + ((:pointer-void) + (wt "ecl_make_foreign_data(Cnil, 0, " loc ")")) + (otherwise + (coercion-error)))) + ((:pointer-void) + (case loc-rep-type + ((:object) + ;; Only foreign data types can be coerced to a pointer + (wt "ecl_foreign_data_pointer_safe(" loc ")")) + ((:cstring) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:cstring) + (coercion-error)) + ((:char*) + (case loc-rep-type + ((:object) + (wt "ecl_base_string_pointer_safe(" loc ")")) + ((:pointer-void) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) ((:void) (wt loc)) - (t - (coercion-error)))))) + (t + (coercion-error)))))) (defun produce-inline-loc (argument-locs arg-types output-rep-type - c-expression side-effects one-liner) + c-expression side-effects one-liner) (let* (args-to-be-saved - coerced-arguments) + coerced-arguments) ;; If the expression begins with @[0-9a-z]*, this means we are ;; saving some variables. (when (and (> (length c-expression) 1) - (eq (char c-expression 0) #\@)) + (eq (char c-expression 0) #\@)) (do ((ndx 1 (1+ ndx))) - ((>= ndx (length c-expression))) - (let ((c (char c-expression ndx))) - (when (eq c #\;) - (setf c-expression (subseq c-expression (1+ ndx))) - (return)) - (unless (alphanumericp c) - (setf args-to-be-saved nil) - (return)) - (push (- (char-code c) (char-code #\0)) - args-to-be-saved)))) + ((>= ndx (length c-expression))) + (let ((c (char c-expression ndx))) + (when (eq c #\;) + (setf c-expression (subseq c-expression (1+ ndx))) + (return)) + (unless (alphanumericp c) + (setf args-to-be-saved nil) + (return)) + (push (- (char-code c) (char-code #\0)) + args-to-be-saved)))) (setf coerced-arguments (coerce-locations argument-locs arg-types args-to-be-saved)) ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) @@ -271,18 +271,18 @@ ;; effects, try to omit it. (when (null output-rep-type) (if side-effects - (progn - (wt-nl) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) - (when one-liner (wt ";"))) - (cmpwarn "Ignoring form ~S" c-expression)) + (progn + (wt-nl) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) + (when one-liner (wt ";"))) + (cmpwarn "Ignoring form ~S" c-expression)) (return-from produce-inline-loc NIL)) ;; If the form is a one-liner, we can simply propagate this expression until the ;; place where the value is used. (when one-liner (return-from produce-inline-loc - `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects + `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects ,(if (equalp output-rep-type '((VALUES &REST T))) 'VALUES NIL)))) @@ -301,7 +301,7 @@ (let ((output-vars (mapcar #'make-output-var output-rep-type))) (loop for v in output-vars do (wt (rep-type-name (var-kind v)) " " v ";")) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) (loop for v in output-vars for i from 0 @@ -320,33 +320,33 @@ (when (and output-vars (not (eq output-vars 'VALUES))) (wt-nl)) (do ((c (read-char s nil nil) - (read-char s nil nil))) - ((null c)) + (read-char s nil nil))) + ((null c)) (case c - (#\@ - (let ((object (read s))) - (cond ((and (consp object) (equal (first object) 'RETURN)) - (if (eq output-vars 'VALUES) - (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") - (let ((ndx (or (second object) 0)) - (l (length output-vars))) - (if (< ndx l) - (wt (nth ndx output-vars)) + (#\@ + (let ((object (read s))) + (cond ((and (consp object) (equal (first object) 'RETURN)) + (if (eq output-vars 'VALUES) + (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" ndx l))))) - (t - (when (and (consp object) (eq (first object) 'QUOTE)) - (setq object (second object))) - (wt (add-object object :permanent t)))))) - (#\# - (let* ((k (read-char s)) - (next-char (peek-char nil s nil nil)) - (index (digit-char-p k 36))) - (cond ((or (null index) (and next-char (alphanumericp next-char))) - (wt #\# k)) - ((< index (length coerced-arguments)) - (wt (nth index coerced-arguments))) - (t - (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) - (otherwise - (write-char c *compiler-output1*)))))) + (t + (when (and (consp object) (eq (first object) 'QUOTE)) + (setq object (second object))) + (wt (add-object object :permanent t)))))) + (#\# + (let* ((k (read-char s)) + (next-char (peek-char nil s nil nil)) + (index (digit-char-p k 36))) + (cond ((or (null index) (and next-char (alphanumericp next-char))) + (wt #\# k)) + ((< index (length coerced-arguments)) + (wt (nth index coerced-arguments))) + (t + (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) + (otherwise + (write-char c *compiler-output1*)))))) diff --git a/src/new-cmp/cmpc-loc.lsp b/src/new-cmp/cmpc-loc.lsp index e57a1b847..11c5c23bb 100644 --- a/src/new-cmp/cmpc-loc.lsp +++ b/src/new-cmp/cmpc-loc.lsp @@ -11,58 +11,58 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; CMPC-LOC Write locations as C expressions +;;;; CMPC-LOC Write locations as C expressions (in-package "C-BACKEND") ;;; Valid locations are: -;;; NIL -;;; T -;;; fixnum -;;; VALUE0 -;;; VALUES -;;; var-object -;;; ( VALUE i ) VALUES(i) -;;; ( VV vv-index ) -;;; ( VV-temp vv-index ) -;;; ( LCL lcl [representation-type]) local variable, type unboxed -;;; ( TEMP temp ) local variable, type object -;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments -;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed -;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function -;;; ( C-INLINE output-type fun/string locs side-effects output-var ) -;;; ( COERCE-LOC representation-type location) -;;; ( CAR lcl ) -;;; ( CDR lcl ) -;;; ( CADR lcl ) -;;; ( FDEFINITION vv-index ) -;;; ( MAKE-CCLOSURE cfun ) -;;; ( FIXNUM-VALUE fixnum-value ) -;;; ( CHARACTER-VALUE character-code ) -;;; ( LONG-FLOAT-VALUE long-float-value vv ) -;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) -;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) -;;; ( STACK-POINTER index ) retrieve a value from the stack -;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) -;;; ( KEYVARS n ) -;;; ( THE type loc ) -;;; VA-ARG -;;; CL-VA-ARG +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; var-object +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-type]) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments +;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed +;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function +;;; ( C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( CAR lcl ) +;;; ( CDR lcl ) +;;; ( CADR lcl ) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( KEYVARS n ) +;;; ( THE type loc ) +;;; VA-ARG +;;; CL-VA-ARG ;;; Valid *DESTINATION* locations are: ;;; -;;; VALUE0 -;;; RETURN Object returned from current function. -;;; TRASH Value may be thrown away. -;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) -;;; ( JUMP-ZERO label ) -;;; ( JUMP-NONZERO label ) +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) +;;; ( JUMP-ZERO label ) +;;; ( JUMP-NONZERO label ) (defun locative-type-from-var-kind (kind) (cdr (assoc kind @@ -180,38 +180,38 @@ (DISCARDED (baboon)) ((SPECIAL GLOBAL) (if (policy-global-var-checking) - (wt "ecl_symbol_value(" var-loc ")") - (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) + (wt "ecl_symbol_value(" var-loc ")") + (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) (t (wt var-loc)) )) (defun wt-fdefinition (fun-name) (let ((vv (add-object fun-name))) (if (and (symbolp fun-name) - (or (not (safe-compile)) - (and (eql (symbol-package fun-name) (find-package "CL")) - (fboundp fun-name) (functionp (fdefinition fun-name))))) - (wt "(" vv "->symbol.gfdef)") - (wt "ecl_fdefinition(" vv ")")))) + (or (not (safe-compile)) + (and (eql (symbol-package fun-name) (find-package "CL")) + (fboundp fun-name) (functionp (fdefinition fun-name))))) + (wt "(" vv "->symbol.gfdef)") + (wt "ecl_fdefinition(" vv ")")))) (defun environment-accessor (fun) (let* ((env-var (env-var-name *env-lvl*)) - (expected-env-size (fun-env fun))) + (expected-env-size (fun-env fun))) (if (< expected-env-size *env*) - (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) - env-var))) + (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) + env-var))) (defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) (declare (type fun fun)) (let* ((closure (fun-closure fun)) - narg) + narg) (cond ((eq closure 'CLOSURE) - (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," - (environment-accessor fun) - ",Cblock)")) - ((eq closure 'LEXICAL) - (baboon)) - ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args - (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",Cnil,Cblock," narg ")")) - (t ; empty environment variable number of args - (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",Cnil,Cblock)"))))) + (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," + (environment-accessor fun) + ",Cblock)")) + ((eq closure 'LEXICAL) + (baboon)) + ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args + (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",Cnil,Cblock," narg ")")) + (t ; empty environment variable number of args + (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",Cnil,Cblock)"))))) diff --git a/src/new-cmp/cmpc-ops.lsp b/src/new-cmp/cmpc-ops.lsp index f0670af16..5fbabff6f 100644 --- a/src/new-cmp/cmpc-ops.lsp +++ b/src/new-cmp/cmpc-ops.lsp @@ -145,10 +145,10 @@ ((REPLACED DISCARDED LEXICAL)) (otherwise (setf block-p t))) finally (progn - (c2unbind-specials nspecials) - (unless (zerop closure) + (c2unbind-specials nspecials) + (unless (zerop closure) (wt-nl "/* End of lifetime of env" *env-lvl* "*/") - (decf *env-lvl*) + (decf *env-lvl*) (format *dump-output* "~&;;; Decreasing environment depth to ~D" *env-lvl*) (decf *env* closure)) @@ -398,7 +398,7 @@ (defun c2funcall-op (destination args) (let* ((loc (pop args)) - (form-type (location-primary-type loc)) + (form-type (location-primary-type loc)) (function-p (and (subtypep form-type 'function) (policy-assume-right-type)))) (set-loc (call-unknown-global-loc nil loc args function-p) @@ -432,7 +432,7 @@ (or (fun-p fun) (and (null fun) (setf fun (find fname *global-funs* :test #'same-fname-p - :key #'fun-name))))) + :key #'fun-name))))) (return-from call-global-loc (call-normal-loc fname fun args))) ;; Call to a global (SETF ...) function @@ -480,24 +480,24 @@ (unless in-core ;; We only write declarations for functions which are not in lisp_external.h (multiple-value-bind (val declared) - (gethash fun-c-name *compiler-declared-globals*) + (gethash fun-c-name *compiler-declared-globals*) (unless declared - (if (= maxarg minarg) - (progn - (wt-nl-h "extern cl_object " fun-c-name "(") - (dotimes (i maxarg) - (when (> i 0) (wt-h1 ",")) - (wt-h1 "cl_object")) - (wt-h1 ");")) - (progn - (wt-nl-h "#ifdef __cplusplus") - (wt-nl-h "extern cl_object " fun-c-name "(...);") - (wt-nl-h "#else") - (wt-nl-h "extern cl_object " fun-c-name "();") - (wt-nl-h "#endif"))) - (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) + (if (= maxarg minarg) + (progn + (wt-nl-h "extern cl_object " fun-c-name "(") + (dotimes (i maxarg) + (when (> i 0) (wt-h1 ",")) + (wt-h1 "cl_object")) + (wt-h1 ");")) + (progn + (wt-nl-h "#ifdef __cplusplus") + (wt-nl-h "extern cl_object " fun-c-name "(...);") + (wt-nl-h "#else") + (wt-nl-h "extern cl_object " fun-c-name "();") + (wt-nl-h "#endif"))) + (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) (let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL - :minarg minarg :maxarg maxarg))) + :minarg minarg :maxarg maxarg))) (call-normal-loc fname fun args))) (defun call-unknown-global-loc (fname loc args &optional function-p) @@ -530,20 +530,20 @@ (unless (fun-cfun fun) (baboon "Function without a C name: ~A" (fun-name fun))) (let* ((minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (fun-c-name (fun-cfun fun)) - (fun-lisp-name (fun-name fun)) - (narg (length args)) - (env nil)) + (maxarg (fun-maxarg fun)) + (fun-c-name (fun-cfun fun)) + (fun-lisp-name (fun-name fun)) + (narg (length args)) + (env nil)) (case (fun-closure fun) (CLOSURE (setf env (environment-accessor fun))) (LEXICAL (let ((lex-lvl (fun-level fun))) - (dotimes (n lex-lvl) - (let* ((j (- lex-lvl n 1)) - (x (lex-env-var-name j))) - (push x args)))))) + (dotimes (n lex-lvl) + (let* ((j (- lex-lvl n 1)) + (x (lex-env-var-name j))) + (push x args)))))) (unless (<= minarg narg maxarg) (cmperr "Wrong number of arguments for function ~S" (or fun-lisp-name 'ANONYMOUS))) @@ -812,19 +812,19 @@ actually use." (defun c2fset (fun fname macro pprint c1forms) (when (fun-no-entry fun) (wt-nl "(void)0; /* No entry created for " - (format nil "~A" (fun-name fun)) - " */") + (format nil "~A" (fun-name fun)) + " */") ;; FIXME! Look at c2function! (new-local fun) (return-from c2fset)) (when (fun-closure fun) (return-from c2fset (c2call-global destination 'SI:FSET c1forms))) (let ((*inline-blocks* 0) - (loc (data-empty-loc))) + (loc (data-empty-loc))) (push (list loc fname fun) *global-cfuns-array*) ;; FIXME! Look at c2function! (new-local fun) (wt-nl (if macro "ecl_cmp_defmacro(" "ecl_cmp_defun(") - loc ");") + loc ");") (close-inline-blocks))) diff --git a/src/new-cmp/cmpc-pass.lsp b/src/new-cmp/cmpc-pass.lsp index dea1e64ce..4d28a3b23 100644 --- a/src/new-cmp/cmpc-pass.lsp +++ b/src/new-cmp/cmpc-pass.lsp @@ -27,10 +27,10 @@ ;;; ;;; Currently this is very very crude: ;;; -;;; * We unbox everything that is declared with a type that fits -;;; in a C variable. -;;; * We cannot unbox function arguments, because they are always -;;; passed with C type cl_object. +;;; * We unbox everything that is declared with a type that fits +;;; in a C variable. +;;; * We cannot unbox function arguments, because they are always +;;; passed with C type cl_object. ;;; (defun pass-decide-var-rep-types (function forms) diff --git a/src/new-cmp/cmpc-set.lsp b/src/new-cmp/cmpc-set.lsp index 2e6ad9b34..2d5c8e216 100644 --- a/src/new-cmp/cmpc-set.lsp +++ b/src/new-cmp/cmpc-set.lsp @@ -9,7 +9,7 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; CMPC-SET Set locations +;;;; CMPC-SET Set locations (in-package "C-BACKEND") diff --git a/src/new-cmp/cmpc-top.lsp b/src/new-cmp/cmpc-top.lsp index c4409a863..175322820 100644 --- a/src/new-cmp/cmpc-top.lsp +++ b/src/new-cmp/cmpc-top.lsp @@ -53,8 +53,8 @@ (wt-nl1 "#include \"" (si::coerce-to-filename data-pathname) "\"")) ;;; Initialization function. (let* ((c-output-file *compiler-output1*) - (*compiler-output1* (make-string-output-stream)) - (*compiler-declared-globals* (make-hash-table))) + (*compiler-output1* (make-string-output-stream)) + (*compiler-declared-globals* (make-hash-table))) ;; Type propagation phase (when *do-type-propagation* @@ -84,17 +84,17 @@ (dolist (l *linking-calls*) (let* ((c-name (fourth l)) - (var-name (fifth l))) + (var-name (fifth l))) (wt-nl-h "static cl_object " c-name "(cl_narg, ...);") (wt-nl-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";"))) ;;; Initial functions for linking calls. (dolist (l *linking-calls*) (let* ((var-name (fifth l)) - (c-name (fourth l)) - (lisp-name (third l))) + (c-name (fourth l)) + (lisp-name (third l))) (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)" - "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) + "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) (wt-nl-h "#ifdef __cplusplus") (wt-nl-h "}") @@ -154,12 +154,12 @@ (*current-toplevel-form* (fun-toplevel-form fun)) (*lcl* (fun-last-lcl fun)) (*last-label* (fun-last-label fun)) - (*lex* 0) + (*lex* 0) (*max-lex* 0) - (*env* (fun-env fun)) ; continue growing env - (*max-env* *env*) + (*env* (fun-env fun)) ; continue growing env + (*max-env* *env*) (*env-lvl* 0) - (*level* (if (eq (fun-closure fun) 'LEXICAL) + (*level* (if (eq (fun-closure fun) 'LEXICAL) (fun-level fun) 0)) (*volatile* (if (fun-volatile-p fun) "volatile " "")) diff --git a/src/new-cmp/cmpcall.lsp b/src/new-cmp/cmpcall.lsp index 1174f17c4..e6a0ba97d 100644 --- a/src/new-cmp/cmpcall.lsp +++ b/src/new-cmp/cmpcall.lsp @@ -25,53 +25,53 @@ (defun unoptimized-funcall (destination fun arguments) (let ((l (length arguments))) (if (<= l si::c-arguments-limit) - (c1with-saved-values (prefix postfix temps (list* fun arguments)) - (nconc prefix - (c1funcall-op destination temps) - postfix)) - (unoptimized-long-call destination fun arguments)))) + (c1with-saved-values (prefix postfix temps (list* fun arguments)) + (nconc prefix + (c1funcall-op destination temps) + postfix)) + (unoptimized-long-call destination fun arguments)))) (defun c1funcall (destination args) (check-args-number 'FUNCALL args 1) (let ((fun (first args)) - (arguments (rest args)) - fd) + (arguments (rest args)) + fd) (cond ;; (FUNCALL (LAMBDA ...) ...) ((and (consp fun) - (eq (first fun) 'LAMBDA)) - (c1translate destination + (eq (first fun) 'LAMBDA)) + (c1translate destination (optimize-funcall/apply-lambda (cdr fun) arguments nil))) - ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) + ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) - (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (c1translate destination + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination (optimize-funcall/apply-lambda (cdr fun) arguments nil))) - ;; (FUNCALL atomic-expression ...) - ((atom fun) - (unoptimized-funcall destination fun arguments)) - ;; (FUNCALL macro-expression ...) - ((let ((name (first fun))) - (setq fd (and (symbolp name) + ;; (FUNCALL atomic-expression ...) + ((atom fun) + (unoptimized-funcall destination fun arguments)) + ;; (FUNCALL macro-expression ...) + ((let ((name (first fun))) + (setq fd (and (symbolp name) ;; We do not want to macroexpand 'THE (not (eq name 'THE)) - (cmp-macro-function name)))) - (c1funcall destination (list* (cmp-expand-macro fd fun) arguments))) - ;; (FUNCALL lisp-expression ...) - ((not (eq (first fun) 'FUNCTION)) - (unoptimized-funcall destination fun arguments)) - ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) - ((si::valid-function-name-p (setq fun (second fun))) - (or (c1call-local destination fun arguments) - (c1call-global destination fun arguments))) - ;; (FUNCALL #'(LAMBDA ...) ...) - ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1translate destination + (cmp-macro-function name)))) + (c1funcall destination (list* (cmp-expand-macro fd fun) arguments))) + ;; (FUNCALL lisp-expression ...) + ((not (eq (first fun) 'FUNCTION)) + (unoptimized-funcall destination fun arguments)) + ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) + ((si::valid-function-name-p (setq fun (second fun))) + (or (c1call-local destination fun arguments) + (c1call-global destination fun arguments))) + ;; (FUNCALL #'(LAMBDA ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA)) + (c1translate destination (optimize-funcall/apply-lambda (rest fun) arguments nil))) - ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) - ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (c1translate destination + ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) + ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination (optimize-funcall/apply-lambda (rest fun) arguments nil))) - (t - (cmperr "Malformed function name: ~A" fun))))) + (t + (cmperr "Malformed function name: ~A" fun))))) diff --git a/src/new-cmp/cmpcatch.lsp b/src/new-cmp/cmpcatch.lsp index 338aaef37..bceecf046 100644 --- a/src/new-cmp/cmpcatch.lsp +++ b/src/new-cmp/cmpcatch.lsp @@ -19,23 +19,23 @@ ;; First we decide where to store the output (c1with-saved-output (values-prefix values-postfix new-destination destination) (let* ((cleanup-form (c1frame-pop)) - (old-env *cmp-env*) - (*cmp-env* (cmp-env-register-cleanup cleanup-form (cmp-env-copy old-env))) - (normal (make-tag :name (gensym "CATCH-NORMAL") :label (next-label))) - (exit (make-tag :name (gensym "CATCH-EXIT") :label (next-label)))) + (old-env *cmp-env*) + (*cmp-env* (cmp-env-register-cleanup cleanup-form (cmp-env-copy old-env))) + (normal (make-tag :name (gensym "CATCH-NORMAL") :label (next-label))) + (exit (make-tag :name (gensym "CATCH-EXIT") :label (next-label)))) (nconc values-prefix - (c1with-saved-one-value (prefix postfix location (pop args)) + (c1with-saved-one-value (prefix postfix location (pop args)) (nconc prefix - (c1frame-set location normal) - postfix)) - (c1set-loc new-destination 'VALUES) - (c1jmp exit) - (list normal) - (c1translate new-destination `(progn ,@args)) - (list exit) - cleanup-form + (c1frame-set location normal) + postfix)) + (c1set-loc new-destination 'VALUES) + (c1jmp exit) + (list normal) + (c1translate new-destination `(progn ,@args)) + (list exit) + cleanup-form (c1set-loc destination new-destination) - values-postfix)))) + values-postfix)))) (defun c1unwind-protect (destination args) (check-args-number 'UNWIND-PROTECT args 1) diff --git a/src/new-cmp/cmpcffi.lsp b/src/new-cmp/cmpcffi.lsp index b562b1bc5..cf777e790 100644 --- a/src/new-cmp/cmpcffi.lsp +++ b/src/new-cmp/cmpcffi.lsp @@ -32,52 +32,52 @@ (defun c1c-inline (destination args) ;; We are on the safe side by assuming that the form has side effects (destructuring-bind (arguments arg-types output-type c-expression - &rest rest - &key (side-effects t) one-liner - &aux output-rep-type) + &rest rest + &key (side-effects t) one-liner + &aux output-rep-type) args (unless (= (length arguments) (length arg-types)) (cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S" - `(C-INLINE ,@args))) + `(C-INLINE ,@args))) ;; We cannot handle :cstrings as input arguments. :cstrings are ;; null-terminated strings, but not all of our lisp strings will ;; be null terminated. In particular, those with a fill pointer ;; will not. (let ((ndx (position :cstring arg-types))) (when ndx - (let* ((var (gensym)) - (value (elt arguments ndx))) - (setf (elt arguments ndx) var - (elt arg-types ndx) :char*) - (return-from c1c-inline - (c1translate destination - `(ffi::with-cstring (,var ,value) - (c-inline ,arguments ,arg-types ,output-type ,c-expression - ,@rest))))))) + (let* ((var (gensym)) + (value (elt arguments ndx))) + (setf (elt arguments ndx) var + (elt arg-types ndx) :char*) + (return-from c1c-inline + (c1translate destination + `(ffi::with-cstring (,var ,value) + (c-inline ,arguments ,arg-types ,output-type ,c-expression + ,@rest))))))) ;; Find out the output types of the inline form. The syntax is rather relaxed - ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) + ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) (flet ((produce-type-pair (type) - (if (c-backend::lisp-type-p type) - (cons type (c-backend::lisp-type->rep-type type)) - (cons (c-backend::rep-type->lisp-type type) type)))) + (if (c-backend::lisp-type-p type) + (cons type (c-backend::lisp-type->rep-type type)) + (cons (c-backend::rep-type->lisp-type type) type)))) (cond ((eq output-type ':void) - (setf output-rep-type '() - output-type 'NIL)) - ((equal output-type '(VALUES &REST t)) - (setf output-rep-type '((VALUES &REST t)))) - ((and (consp output-type) (eql (first output-type) 'VALUES)) - (setf output-rep-type (mapcar #'cdr (mapcar #'produce-type-pair (rest output-type))) - output-type 'T)) - (t - (let ((x (produce-type-pair output-type))) - (setf output-type (car x) - output-rep-type (list (cdr x))))))) + (setf output-rep-type '() + output-type 'NIL)) + ((equal output-type '(VALUES &REST t)) + (setf output-rep-type '((VALUES &REST t)))) + ((and (consp output-type) (eql (first output-type) 'VALUES)) + (setf output-rep-type (mapcar #'cdr (mapcar #'produce-type-pair (rest output-type))) + output-type 'T)) + (t + (let ((x (produce-type-pair output-type))) + (setf output-type (car x) + output-rep-type (list (cdr x))))))) (let* ((processed-arguments '())) (unless (and (listp arguments) - (listp arg-types) - (stringp c-expression)) - (cmperr "C-INLINE: wrong type of arguments ~S" - arguments arg-types c-expression)) + (listp arg-types) + (stringp c-expression)) + (cmperr "C-INLINE: wrong type of arguments ~S" + arguments arg-types c-expression)) (unless (= (length arguments) (length arg-types)) (cmperr "C-INLINE: mismatch between sizes of argument list and argument types.")) diff --git a/src/new-cmp/cmpclos.lsp b/src/new-cmp/cmpclos.lsp index b94c41269..3d48e81a6 100644 --- a/src/new-cmp/cmpclos.lsp +++ b/src/new-cmp/cmpclos.lsp @@ -21,9 +21,9 @@ (when (fboundp fname) (let ((gf (fdefinition fname))) (when (typep gf 'standard-generic-function) - ;;(check-generic-function-args gf args) - (when (policy-inline-slot-access-p) - (maybe-optimize-slot-accessor destination fname gf args)))))) + ;;(check-generic-function-args gf args) + (when (policy-inline-slot-access-p) + (maybe-optimize-slot-accessor destination fname gf args)))))) ;;; ;;; PRECOMPUTE APPLICABLE METHODS @@ -36,12 +36,12 @@ (defun precompute-applicable-methods (methods c-args) (flet ((applicable-method-p (m) - (loop for specializer in (clos:method-specializers m) - for arg in c-args - always (let ((arg-type (c1form-primary-type arg))) - (subtypep arg-type (if (consp specializer) - `(member ,(second specializer)) - specializer)))))) + (loop for specializer in (clos:method-specializers m) + for arg in c-args + always (let ((arg-type (c1form-primary-type arg))) + (subtypep arg-type (if (consp specializer) + `(member ,(second specializer)) + specializer)))))) (delete-if-not #'applicable-method-p methods))) ;;; @@ -66,10 +66,10 @@ with reader-class = (find-class 'clos:standard-reader-method) with writer-class = (find-class 'clos:standard-writer-method) do (let ((method-class (class-of method))) - (cond ((si::subclassp method-class reader-class) - (push method readers)) - ((si::subclassp method-class writer-class) - (push method writers)))) + (cond ((si::subclassp method-class reader-class) + (push method readers)) + ((si::subclassp method-class writer-class) + (push method writers)))) finally (return (values readers writers)))) (defun maybe-optimize-slot-accessor (destination fname gf args) @@ -77,43 +77,43 @@ (find-slot-accessors gf) ;(format t "~%;;; Found ~D readers and ~D writers for ~A" (length readers) (length writers) fname) (cond ((and readers writers) - (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods" - fname)) - ((or (not gf) (not (or readers writers))) - nil) - ((/= (length args) (length (clos::generic-function-spec-list gf))) - (cmpwarn "Too many arguments for generic function ~A" fname) - nil) - (readers - (try-optimize-slot-reader destination readers args)) - (writers - (try-optimize-slot-writer destination writers args))))) + (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods" + fname)) + ((or (not gf) (not (or readers writers))) + nil) + ((/= (length args) (length (clos::generic-function-spec-list gf))) + (cmpwarn "Too many arguments for generic function ~A" fname) + nil) + (readers + (try-optimize-slot-reader destination readers args)) + (writers + (try-optimize-slot-writer destination writers args))))) (defun try-optimize-slot-reader (destination readers args) (let* ((object (first args)) - (c-object (c1expr 'SHOULD-BE-TEMP object)) - (readers (precompute-applicable-methods readers (list c-object)))) + (c-object (c1expr 'SHOULD-BE-TEMP object)) + (readers (precompute-applicable-methods readers (list c-object)))) ;(format t "~%;;; Found ~D really applicable reader" (length readers)) (when (= (length readers) 1) (let ((reader (first readers))) - (when (typep reader 'clos:standard-reader-method) - (let* ((slotd (clos:accessor-method-slot-definition reader)) - (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) - (c1expr destination `(clos::safe-instance-ref ,object ,index))))))))) + (when (typep reader 'clos:standard-reader-method) + (let* ((slotd (clos:accessor-method-slot-definition reader)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + (c1expr destination `(clos::safe-instance-ref ,object ,index))))))))) (defun try-optimize-slot-writer (destination orig-writers args) (let* ((c-args (loop for f in args collect (c1expr 'SHOULD-BE-TEMPS args))) - (writers (precompute-applicable-methods orig-writers c-args))) + (writers (precompute-applicable-methods orig-writers c-args))) ;(format t "~%;;; Found ~D really applicable writer" (length writers)) (when (= (length writers) 1) (let ((writer (first writers))) - (when (typep writer 'clos:standard-writer-method) - (let* ((slotd (clos:accessor-method-slot-definition writer)) - (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) - (c1expr destination `(si::instance-set ,(second args) + (when (typep writer 'clos:standard-writer-method) + (let* ((slotd (clos:accessor-method-slot-definition writer)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + (c1expr destination `(si::instance-set ,(second args) ,index ,(first args)))))))))) (progn . diff --git a/src/new-cmp/cmpdata.lsp b/src/new-cmp/cmpdata.lsp index 0a356082c..151046e46 100644 --- a/src/new-cmp/cmpdata.lsp +++ b/src/new-cmp/cmpdata.lsp @@ -38,19 +38,19 @@ (defun data-init (&optional filename) (if (and filename (probe-file filename)) (with-open-file (s filename :direction :input) - (setf *permanent-objects* (read s) - *temporary-objects* (read s))) + (setf *permanent-objects* (read s) + *temporary-objects* (read s))) (setf *permanent-objects* (make-array 128 :adjustable t :fill-pointer 0) - *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) + *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) (defun data-get-all-objects () ;; We collect all objects that are to be externalized, but filter out ;; those which will be created by a lisp form. (loop for i in (nconc (map 'list #'first *permanent-objects*) - (map 'list #'first *temporary-objects*)) - collect (if (gethash i *load-objects*) - 0 - i))) + (map 'list #'first *temporary-objects*)) + collect (if (gethash i *load-objects*) + 0 + i))) (defun data-empty-loc () (add-object 0 :duplicate t :permanent t)) @@ -61,47 +61,47 @@ (defun add-load-form (object location) (when (clos::need-to-make-load-form-p object *cmp-env*) (if (not (eq *compiler-phase* 't1)) - (error "Unable to internalize complex object ~A in ~a phase" + (error "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*) - (multiple-value-bind (make-form init-form) (make-load-form object) - (setf (gethash object *load-objects*) location) + (multiple-value-bind (make-form init-form) (make-load-form object) + (setf (gethash object *load-objects*) location) (setf *make-forms* (nconc *make-forms* (and make-form (c1translate location make-form)) (and init-form (c1translate location init-form)))))))) (defun add-object (object &key (duplicate nil) - (permanent (or (symbolp object) *permanent-data*))) + (permanent (or (symbolp object) *permanent-data*))) ;; FIXME! Currently we have two data vectors and, when compiling ;; files, it may happen that a constant is duplicated and stored ;; both in VV and VVtemp. This would not be a problem if the ;; constant were readable, but due to using MAKE-LOAD-FORM we may ;; end up having two non-EQ objects created for the same value. (let* ((test (if *compiler-constants* 'eq 'equal)) - (array (if permanent *permanent-objects* *temporary-objects*)) - (vv (if permanent 'VV 'VV-temp)) - (x (or (and (not permanent) - (find object *permanent-objects* :test test - :key #'first)) - (find object array :test test :key #'first))) - (next-ndx (length array)) - found) + (array (if permanent *permanent-objects* *temporary-objects*)) + (vv (if permanent 'VV 'VV-temp)) + (x (or (and (not permanent) + (find object *permanent-objects* :test test + :key #'first)) + (find object array :test test :key #'first))) + (next-ndx (length array)) + found) (cond ((and x duplicate) - (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) - (vector-push-extend (list object x next-ndx) array) - x) - (x - (second x)) - ((and (not duplicate) - (symbolp object) - (multiple-value-setq (found x) (si::mangle-name object))) - x) - (t - (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) - (vector-push-extend (list object x next-ndx) array) - (unless *compiler-constants* - (add-load-form object x)) - x)))) + (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) + (vector-push-extend (list object x next-ndx) array) + x) + (x + (second x)) + ((and (not duplicate) + (symbolp object) + (multiple-value-setq (found x) (si::mangle-name object))) + x) + (t + (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) + (vector-push-extend (list object x next-ndx) array) + (unless *compiler-constants* + (add-load-form object x)) + x)))) (defun add-symbol (symbol) (add-object symbol :duplicate nil :permanent t)) @@ -115,10 +115,10 @@ ;; We search for keyword lists that are similar. However, the list ;; *OBJECTS* contains elements in decreasing order!!! (let ((x (search keywords *permanent-objects* - :test #'(lambda (k record) (eq k (first record)))))) + :test #'(lambda (k record) (eq k (first record)))))) (if x (second (elt *permanent-objects* x)) - (prog1 - (add-object (pop keywords) :duplicate t :permanent t) - (dolist (k keywords) - (add-object k :duplicate t :permanent t)))))) + (prog1 + (add-object (pop keywords) :duplicate t :permanent t) + (dolist (k keywords) + (add-object k :duplicate t :permanent t)))))) diff --git a/src/new-cmp/cmpeval.lsp b/src/new-cmp/cmpeval.lsp index f968297ca..dee1a99d4 100644 --- a/src/new-cmp/cmpeval.lsp +++ b/src/new-cmp/cmpeval.lsp @@ -17,29 +17,29 @@ (defun c1expr (destination form) (setq form (catch *cmperr-tag* (cond ((symbolp form) - (setq form (chk-symbol-macrolet form)) - (cond ((not (symbolp form)) - (c1expr destination form)) - ((eq form nil) (c1nil destination)) - ((eq form t) (c1t destination)) - ((keywordp form) + (setq form (chk-symbol-macrolet form)) + (cond ((not (symbolp form)) + (c1expr destination form)) + ((eq form nil) (c1nil destination)) + ((eq form t) (c1t destination)) + ((keywordp form) (c1set-loc destination (add-symbol form))) - ((constantp form) - (or (c1constant-value destination (symbol-value form) + ((constantp form) + (or (c1constant-value destination (symbol-value form) :only-small-values t) - (c1var destination form))) - (t (c1var destination form)))) + (c1var destination form))) + (t (c1var destination form)))) ((tag-p form) form) - ((consp form) - (let* ((fun (car form)) + ((consp form) + (let* ((fun (car form)) (*current-form* form)) - (cond ((symbolp fun) - (c1call-symbol destination fun (cdr form))) - ((and (consp fun) (eq (car fun) 'LAMBDA)) - (c1funcall destination form)) - (t (cmperr "~s is not a legal function name." fun))))) - (t (c1constant-value destination form :always t))))) + (cond ((symbolp fun) + (c1call-symbol destination fun (cdr form))) + ((and (consp fun) (eq (car fun) 'LAMBDA)) + (c1funcall destination form)) + (t (cmperr "~s is not a legal function name." fun))))) + (t (c1constant-value destination form :always t))))) (if (eq form '*cmperr-tag*) (c1nil destination) form)) @@ -77,27 +77,27 @@ (cond ((and (setq basic-fd (gethash fname +c1-dispatch-table+)) (special-operator-p fname)) (funcall basic-fd destination args)) - ((c1call-local destination fname args)) - ((setq fd (cmp-env-search-macro fname)) - (c1expr destination (cmp-expand-macro fd (list* fname args)))) - ((and basic-fd (inline-possible fname)) - (funcall basic-fd destination args)) - ((and (setq fd (compiler-macro-function fname)) - (inline-possible fname) - (let ((success nil)) - (multiple-value-setq (fd success) - (cmp-expand-macro fd (list* fname args))) - success)) - (c1expr destination fd)) - ((setq fd (cmp-macro-function fname)) - (c1expr destination (cmp-expand-macro fd (list* fname args)))) - (t (c1call-global destination fname args)))) + ((c1call-local destination fname args)) + ((setq fd (cmp-env-search-macro fname)) + (c1expr destination (cmp-expand-macro fd (list* fname args)))) + ((and basic-fd (inline-possible fname)) + (funcall basic-fd destination args)) + ((and (setq fd (compiler-macro-function fname)) + (inline-possible fname) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd (list* fname args))) + success)) + (c1expr destination fd)) + ((setq fd (cmp-macro-function fname)) + (c1expr destination (cmp-expand-macro fd (list* fname args)))) + (t (c1call-global destination fname args)))) (defun c1call-local (destination fname args) (let ((fun (local-function-ref fname))) (when fun (when (> (length args) si::c-arguments-limit) - (return-from c1call-local + (return-from c1call-local (unoptimized-long-call destination `#',fname args))) (c1with-saved-values (prefix postfix temps args) (nconc prefix @@ -106,15 +106,15 @@ (defun c1call-global (destination fname args) (let ((l (length args)) - forms) + forms) (cond ((> l si::c-arguments-limit) - (unoptimized-long-call destination `#',fname args)) + (unoptimized-long-call destination `#',fname args)) #| - ((maybe-optimize-structure-access destination fname args)) - #+clos - ((maybe-optimize-generic-function destination fname args)) + ((maybe-optimize-structure-access destination fname args)) + #+clos + ((maybe-optimize-generic-function destination fname args)) |# - (t + (t (c1with-saved-values (prefix postfix temps args) (nconc prefix (c1call-global-op destination fname temps) @@ -123,22 +123,22 @@ ;;; ---------------------------------------------------------------------- (defvar *compiler-temps* - '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) + '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) (defmacro sys::define-inline-function (name vars &body body) (let ((temps nil) - (*compiler-temps* *compiler-temps*)) + (*compiler-temps* *compiler-temps*)) (dolist (var vars) (if (and (symbolp var) - (not (member var '(&OPTIONAL &REST &KEY &AUX) :test #'eq))) - (push (or (pop *compiler-temps*) - (gentemp "TMP" (find-package 'COMPILER))) - temps) - (error "The parameter ~s for the inline function ~s is illegal." - var name))) + (not (member var '(&OPTIONAL &REST &KEY &AUX) :test #'eq))) + (push (or (pop *compiler-temps*) + (gentemp "TMP" (find-package 'COMPILER))) + temps) + (error "The parameter ~s for the inline function ~s is illegal." + var name))) (let ((binding (cons 'LIST (mapcar - #'(lambda (var temp) `(list ',var ,temp)) - vars temps)))) + #'(lambda (var temp) `(list ',var ,temp)) + vars temps)))) `(progn - (defun ,name ,vars ,@body) - (define-compiler-macro ,name ,temps (list* 'LET ,binding ',body)))))) + (defun ,name ,vars ,@body) + (define-compiler-macro ,name ,temps (list* 'LET ,binding ',body)))))) diff --git a/src/new-cmp/cmpflet.lsp b/src/new-cmp/cmpflet.lsp index db30c3c34..207dc6671 100644 --- a/src/new-cmp/cmpflet.lsp +++ b/src/new-cmp/cmpflet.lsp @@ -40,9 +40,9 @@ ;; this functions in the processed body. (dolist (def definitions) (cmpck (or (endp def) - (not (si::valid-function-name-p (car def))) - (endp (cdr def))) - "The local function definition ~s is illegal." def) + (not (si::valid-function-name-p (car def))) + (endp (cdr def))) + "The local function definition ~s is illegal." def) (let ((name (pop def))) (cmpck (member name fun-names :test #'same-fname-p) "The function ~s was already defined." name) @@ -69,11 +69,11 @@ ;; on inspecting the functions until the closure type does not ;; change. (loop while - (let ((x nil)) - (loop for f in local-funs - when (compute-fun-closure-type f) - do (setf x t)) - x)) + (let ((x nil)) + (loop for f in local-funs + when (compute-fun-closure-type f) + do (setf x t)) + x)) output)) @@ -121,77 +121,77 @@ (defun fun-referred-local-vars (fun) (remove-if #'(lambda (v) (member (var-kind v) '(SPECIAL GLOBAL REPLACED DISCARDED))) - (fun-referred-vars fun))) + (fun-referred-vars fun))) (defun compute-fun-closure-type (fun) (labels ((closure-type (fun &aux (lambda-form (fun-lambda fun))) - (let ((vars (fun-referred-local-vars fun)) - (funs (remove fun (fun-referred-funs fun) :test #'child-p)) - (closure nil)) - ;; it will have a full closure if it refers external non-global variables - (dolist (var vars) - ;; ...across CB - (if (ref-ref-ccb var) - (setf closure 'CLOSURE) - (unless closure (setf closure 'LEXICAL)))) - ;; ...or if it directly calls a function - (dolist (f funs) - ;; .. which has a full closure - (case (fun-closure f) - (CLOSURE (setf closure 'CLOSURE)) - (LEXICAL (unless closure (setf closure 'LEXICAL))))) - ;; ...or the function itself is referred across CB, either + (let ((vars (fun-referred-local-vars fun)) + (funs (remove fun (fun-referred-funs fun) :test #'child-p)) + (closure nil)) + ;; it will have a full closure if it refers external non-global variables + (dolist (var vars) + ;; ...across CB + (if (ref-ref-ccb var) + (setf closure 'CLOSURE) + (unless closure (setf closure 'LEXICAL)))) + ;; ...or if it directly calls a function + (dolist (f funs) + ;; .. which has a full closure + (case (fun-closure f) + (CLOSURE (setf closure 'CLOSURE)) + (LEXICAL (unless closure (setf closure 'LEXICAL))))) + ;; ...or the function itself is referred across CB, either ;; directly or through a second indirection to the function ;; variable. - (when closure - (when (or (fun-ref-ccb fun) - (and (fun-var fun) + (when closure + (when (or (fun-ref-ccb fun) + (and (fun-var fun) (not (unused-variable-p (fun-var fun))))) - (setf closure 'CLOSURE))) - closure)) + (setf closure 'CLOSURE))) + closure)) (child-p (presumed-parent fun) - (let ((real-parent (fun-parent fun))) - (when real-parent - (or (eq real-parent presumed-parent) - (child-p real-parent presumed-parent)))))) + (let ((real-parent (fun-parent fun))) + (when real-parent + (or (eq real-parent presumed-parent) + (child-p real-parent presumed-parent)))))) ;; This recursive algorithm is guaranteed to stop when functions ;; do not change. (let ((new-type (closure-type fun)) - (old-type (fun-closure fun))) + (old-type (fun-closure fun))) ;; (format t "~%CLOSURE-TYPE: ~A ~A -> ~A, ~A" (fun-name fun) -;; old-type new-type (fun-parent fun)) +;; old-type new-type (fun-parent fun)) ;; (print (fun-referred-vars fun)) ;; Same type (when (eq new-type old-type) - (return-from compute-fun-closure-type nil)) + (return-from compute-fun-closure-type nil)) ;; {lexical,closure} -> no closure! ;; closure -> {lexical, no closure} (when (or (and (not new-type) old-type) - (eq old-type 'CLOSURE)) - (baboon)) + (eq old-type 'CLOSURE)) + (baboon)) (setf (fun-closure fun) new-type) ;; All external, non-global variables become of type closure (when (eq new-type 'CLOSURE) - (when (fun-global fun) - (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" + (when (fun-global fun) + (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" (fun-name fun) (mapcar #'var-name (fun-referred-vars fun)))) - (dolist (var (fun-referred-local-vars fun)) - (setf (var-ref-clb var) nil - (var-ref-ccb var) t - (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT)) - (dolist (f (fun-referred-funs fun)) - (setf (fun-ref-ccb f) t))) + (dolist (var (fun-referred-local-vars fun)) + (setf (var-ref-clb var) nil + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (dolist (f (fun-referred-funs fun)) + (setf (fun-ref-ccb f) t))) ;; If the status of some of the children changes, we have ;; to recompute the closure type. (do ((finish nil t) - (recompute nil)) - (finish - (when recompute (compute-fun-closure-type fun))) - (dolist (f (fun-child-funs fun)) - (when (compute-fun-closure-type f) - (setf recompute t finish nil)))) + (recompute nil)) + (finish + (when recompute (compute-fun-closure-type fun))) + (dolist (f (fun-child-funs fun)) + (when (compute-fun-closure-type f) + (setf recompute t finish nil)))) t))) (defun local-function-ref (fname &optional build-object) @@ -199,22 +199,22 @@ (cmp-env-search-function fname) (when fun (when (functionp fun) - (when build-object - ;; Macro definition appears in #'.... This should not happen. - (cmperr "The name of a macro ~A was found in special form FUNCTION." name)) - (return-from local-function-ref nil)) + (when build-object + ;; Macro definition appears in #'.... This should not happen. + (cmperr "The name of a macro ~A was found in special form FUNCTION." name)) + (return-from local-function-ref nil)) (incf (fun-ref fun)) (cond (build-object - (setf (fun-ref-ccb fun) t)) - (*current-function* - (push fun (fun-referred-funs *current-function*)))) + (setf (fun-ref-ccb fun) t)) + (*current-function* + (push fun (fun-referred-funs *current-function*)))) ;; we introduce a variable to hold the funob (let ((var (fun-var fun))) - (cond (ccb (when build-object - (setf (var-ref-ccb var) t - (var-kind var) 'CLOSURE)) - (setf (fun-ref-ccb fun) t)) - (clb (when build-object - (setf (var-ref-clb var) t - (var-kind var) 'LEXICAL)))))) + (cond (ccb (when build-object + (setf (var-ref-ccb var) t + (var-kind var) 'CLOSURE)) + (setf (fun-ref-ccb fun) t)) + (clb (when build-object + (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL)))))) fun)) diff --git a/src/new-cmp/cmpform.lsp b/src/new-cmp/cmpform.lsp index 47684f096..26e0fa441 100644 --- a/src/new-cmp/cmpform.lsp +++ b/src/new-cmp/cmpform.lsp @@ -20,18 +20,18 @@ #+(or) (defmacro make-c1form-alone (name &rest args) (let ((info-args '()) - (form-args '())) + (form-args '())) (do ((l args (cdr l))) - ((endp l)) + ((endp l)) (let ((key (first l))) - (cond ((not (keywordp key)) - (baboon)) - ((eq key ':args) - (setf form-args (rest l)) - (return)) - (t - (setf info-args (list* key (second l) info-args) - l (cdr l)))))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) `(do-make-c1form :name ,name :args (list ,@form-args) :form *current-form* :file *compile-file-truename* @@ -40,18 +40,18 @@ (defun make-c1form-alone (name &rest args) (let ((info-args '()) - (form-args '())) + (form-args '())) (do ((l args (cdr l))) - ((endp l)) + ((endp l)) (let ((key (first l))) - (cond ((not (keywordp key)) - (baboon)) - ((eq key ':args) - (setf form-args (rest l)) - (return)) - (t - (setf info-args (list* key (second l) info-args) - l (cdr l)))))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) (apply #'do-make-c1form :name name :args form-args :form *current-form* :file *compile-file-truename* diff --git a/src/new-cmp/cmpfun.lsp b/src/new-cmp/cmpfun.lsp index d7b15a90f..c31fcb2bb 100644 --- a/src/new-cmp/cmpfun.lsp +++ b/src/new-cmp/cmpfun.lsp @@ -42,7 +42,7 @@ (defun function-may-change-sp (fname) (not (or (get-sysprop fname 'no-side-effects) - (get-sysprop fname 'no-sp-change)))) + (get-sysprop fname 'no-sp-change)))) (defun function-can-be-evaluated-at-compile-time (fname) (get-sysprop fname 'pure)) @@ -74,9 +74,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (let (narg) (and (not (eq (fun-closure fun) 'CLOSURE)) - (= (fun-minarg fun) (setf narg (fun-maxarg fun))) - (<= narg si::c-arguments-limit) - narg))) + (= (fun-minarg fun) (setf narg (fun-maxarg fun))) + (<= narg si::c-arguments-limit) + narg))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -88,23 +88,23 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (defun c1apply (destination args) (check-args-number 'APPLY args 2) (let* ((fun (first args)) - (arguments (rest args))) + (arguments (rest args))) (cond ((and (consp fun) - (eq (first fun) 'LAMBDA)) - (c1translate destination + (eq (first fun) 'LAMBDA)) + (c1translate destination (optimize-funcall/apply-lambda (cdr fun) arguments t))) - ((and (consp fun) - (eq (first fun) 'EXT::LAMBDA-BLOCK)) - (setf fun (macroexpand-1 fun)) - (c1translate destination + ((and (consp fun) + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination (optimize-funcall/apply-lambda (cdr fun) arguments t))) - ((and (consp fun) - (eq (first fun) 'FUNCTION) - (consp (second fun)) - (member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK))) - (c1apply destination (list* (second fun) arguments))) - (t - (c1funcall destination (list* '#'APPLY args)))))) + ((and (consp fun) + (eq (first fun) 'FUNCTION) + (consp (second fun)) + (member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK))) + (c1apply destination (list* (second fun) arguments))) + (t + (c1funcall destination (list* '#'APPLY args)))))) (defun expand-rplaca/d (car-p cons value env) (flet ((main-form (car-p cons value) @@ -191,21 +191,21 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (define-compiler-macro boole (&whole form op-code op1 op2) (or (and (constantp op-code) - (case (eval op-code) - (#. boole-clr `(progn ,op1 ,op2 0)) - (#. boole-set `(progn ,op1 ,op2 -1)) - (#. boole-1 `(prog1 ,op1 ,op2)) - (#. boole-2 `(progn ,op1 ,op2)) - (#. boole-c1 `(prog1 (lognot ,op1) ,op2)) - (#. boole-c2 `(progn ,op1 (lognot ,op2))) - (#. boole-and `(logand ,op1 ,op2)) - (#. boole-ior `(logior ,op1 ,op2)) - (#. boole-xor `(logxor ,op1 ,op2)) - (#. boole-eqv `(logeqv ,op1 ,op2)) - (#. boole-nand `(lognand ,op1 ,op2)) - (#. boole-nor `(lognor ,op1 ,op2)) - (#. boole-andc1 `(logandc1 ,op1 ,op2)) - (#. boole-andc2 `(logandc2 ,op1 ,op2)) - (#. boole-orc1 `(logorc1 ,op1 ,op2)) - (#. boole-orc2 `(logorc2 ,op1 ,op2)))) + (case (eval op-code) + (#. boole-clr `(progn ,op1 ,op2 0)) + (#. boole-set `(progn ,op1 ,op2 -1)) + (#. boole-1 `(prog1 ,op1 ,op2)) + (#. boole-2 `(progn ,op1 ,op2)) + (#. boole-c1 `(prog1 (lognot ,op1) ,op2)) + (#. boole-c2 `(progn ,op1 (lognot ,op2))) + (#. boole-and `(logand ,op1 ,op2)) + (#. boole-ior `(logior ,op1 ,op2)) + (#. boole-xor `(logxor ,op1 ,op2)) + (#. boole-eqv `(logeqv ,op1 ,op2)) + (#. boole-nand `(lognand ,op1 ,op2)) + (#. boole-nor `(lognor ,op1 ,op2)) + (#. boole-andc1 `(logandc1 ,op1 ,op2)) + (#. boole-andc2 `(logandc2 ,op1 ,op2)) + (#. boole-orc1 `(logorc1 ,op1 ,op2)) + (#. boole-orc2 `(logorc2 ,op1 ,op2)))) form)) diff --git a/src/new-cmp/cmplam.lsp b/src/new-cmp/cmplam.lsp index 89442c363..1cb470f6b 100644 --- a/src/new-cmp/cmplam.lsp +++ b/src/new-cmp/cmplam.lsp @@ -16,33 +16,33 @@ ;;; During Pass1, a lambda-list ;;; -;;; ( { var }* -;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] -;;; [ &rest var ] -;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* -;;; [&allow-other-keys]] -;;; [ &aux {var | (var [initform])}*] +;;; ( { var }* +;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] +;;; [ &rest var ] +;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* +;;; [&allow-other-keys]] +;;; [ &aux {var | (var [initform])}*] ;;; ) ;;; ;;; is transformed into ;;; -;;; ( ( { var }* ) ; required -;;; ( { var initform svar }* ) ; optional -;;; { var | nil } ; rest -;;; allow-other-keys-flag -;;; ( { kwd-vv-index var initform svar }* ) ; key +;;; ( ( { var }* ) ; required +;;; ( { var initform svar }* ) ; optional +;;; { var | nil } ; rest +;;; allow-other-keys-flag +;;; ( { kwd-vv-index var initform svar }* ) ; key ;;; ) ;;; ;;; where -;;; svar: NIL ; means svar is not supplied -;;; | var +;;; svar: NIL ; means svar is not supplied +;;; | var ;;; ;;; &aux parameters will be embedded into LET*. ;;; ;;; c1lambda-expr receives -;;; ( lambda-list { doc | decl }* . body ) +;;; ( lambda-list { doc | decl }* . body ) ;;; and returns -;;; ( lambda info-object lambda-list' doc body' ) +;;; ( lambda info-object lambda-list' doc body' ) ;;; ;;; Doc is NIL if no doc string is supplied. ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are @@ -59,14 +59,14 @@ (defun add-referred-variables-to-function (fun var-list) (setf (fun-referred-vars fun) - (set-difference (union (fun-referred-vars fun) var-list) - (fun-local-vars fun))) + (set-difference (union (fun-referred-vars fun) var-list) + (fun-local-vars fun))) fun) (defun c1compile-function (lambda-list-and-body &key (fun (make-fun)) - (name (fun-name fun)) (CB/LB 'CB)) + (name (fun-name fun)) (CB/LB 'CB)) (setf (fun-name fun) name - (fun-parent fun) *current-function*) + (fun-parent fun) *current-function*) (when *current-function* (push fun (fun-child-funs *current-function*))) (let* ((*lcl* 0) @@ -115,8 +115,8 @@ (fun-cfun fun) cfun (fun-exported fun) exported-p (fun-no-entry fun) no-entry-p - (fun-closure fun) nil - (fun-description fun) name))) + (fun-closure fun) nil + (fun-description fun) name))) (defun c1set-function-closure-type (fun) (let ((children (fun-child-funs fun))) @@ -125,20 +125,20 @@ ;; are registered with this function... ;; (reduce #'add-referred-variables-to-function - (mapcar #'fun-referred-vars children) - :initial-value fun) + (mapcar #'fun-referred-vars children) + :initial-value fun) (reduce #'add-referred-variables-to-function - (mapcar #'fun-referred-vars (fun-referred-funs fun)) - :initial-value fun) + (mapcar #'fun-referred-vars (fun-referred-funs fun)) + :initial-value fun) ;; ;; ...and then compute closure type for function and children ;; (do ((finish nil)) - (finish) + (finish) (setf finish t) (dolist (f children) - (when (compute-fun-closure-type f) - (setf finish nil)))) + (when (compute-fun-closure-type f) + (setf finish nil)))) (compute-fun-closure-type fun) (when (fun-global fun) (if (fun-closure fun) @@ -171,7 +171,7 @@ (when block-name (setq body (list (cons 'BLOCK (cons block-name body))))) (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys aux-vars) + allow-other-keys aux-vars) (cmp-process-lambda-list (car lambda-expr)) ;; We need to add the declarations right here, because they should @@ -240,8 +240,8 @@ (aux-vars (nconc (cdr type-checks) aux-vars)) (aux-var-names (loop for v in aux-vars by #'cddr collect (first v))) - (new-variables (cmp-env-new-variables *cmp-env* old-env)) - (already-declared-name (set-difference (mapcar #'var-name new-variables) + (new-variables (cmp-env-new-variables *cmp-env* old-env)) + (already-declared-name (set-difference (mapcar #'var-name new-variables) aux-var-names))) ;; Gather declarations for &aux variables, either special... (let ((specials (set-difference ss already-declared-names))) @@ -255,8 +255,8 @@ (push `(ignorable ,@ignorables) declarations))) ;; ...or type declarations (loop for (var . type) in ts - unless (member var already-declared-names) - do (push `(type ,type ,var) declarations)) + unless (member var already-declared-names) + do (push `(type ,type ,var) declarations)) (let ((*cmp-env* (cmp-env-copy))) (when (policy-debug-variable-bindings) @@ -404,98 +404,98 @@ #| Steps: 1. defun creates declarations for requireds + va_alist 2. c2lambda-expr adds declarations for: - unboxed requireds - lexical optionals (+ supplied-p), rest, keywords (+ supplied-p) + unboxed requireds + lexical optionals (+ supplied-p), rest, keywords (+ supplied-p) Lexical optionals and keywords can be unboxed if: - a. there is more then one reference in the body - b. they are not referenced in closures + a. there is more then one reference in the body + b. they are not referenced in closures 3. binding is performed for: - special or unboxed requireds - optionals, rest, keywords + special or unboxed requireds + optionals, rest, keywords |# (defun optimize-funcall/apply-lambda (lambda-form arguments apply-p - &aux body apply-list apply-var - let-vars extra-stmts all-keys) + &aux body apply-list apply-var + let-vars extra-stmts all-keys) (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys aux-vars) + allow-other-keys aux-vars) (cmp-process-lambda-list (car lambda-form)) (when apply-p (setf apply-list (first (last arguments)) - apply-var (gensym) - arguments (butlast arguments))) + apply-var (gensym) + arguments (butlast arguments))) (setf arguments (copy-list arguments)) (do ((scan arguments (cdr scan))) - ((endp scan)) + ((endp scan)) (let ((form (first scan))) - (unless (constantp form) - (let ((aux-var (gensym))) - (push `(,aux-var ,form) let-vars) - (setf (car scan) aux-var))))) + (unless (constantp form) + (let ((aux-var (gensym))) + (push `(,aux-var ,form) let-vars) + (setf (car scan) aux-var))))) (when apply-var (push `(,apply-var ,apply-list) let-vars)) (dolist (i (cdr requireds)) (push (list i - (cond (arguments - (pop arguments)) - (apply-p - `(if ,apply-var - (pop ,apply-var) - (si::dm-too-few-arguments))) - (t - (cmperr "Too few arguments for lambda form ~S" + (cond (arguments + (pop arguments)) + (apply-p + `(if ,apply-var + (pop ,apply-var) + (si::dm-too-few-arguments))) + (t + (cmperr "Too few arguments for lambda form ~S" (cons 'LAMBDA lambda-form))))) - let-vars)) + let-vars)) (do ((scan (cdr optionals) (cdddr scan))) - ((endp scan)) + ((endp scan)) (let ((opt-var (first scan)) - (opt-flag (third scan)) - (opt-value (second scan))) - (cond (arguments - (setf let-vars - (list* `(,opt-var ,(pop arguments)) - `(,opt-flag t) - let-vars))) - (apply-p - (setf let-vars - (list* `(,opt-var (if ,apply-var - (pop ,apply-var) - ,opt-value)) - `(,opt-flag ,apply-var) - let-vars))) - (t - (setf let-vars - (list* `(,opt-var ,opt-value) - `(,opt-flag nil) - let-vars)))))) + (opt-flag (third scan)) + (opt-value (second scan))) + (cond (arguments + (setf let-vars + (list* `(,opt-var ,(pop arguments)) + `(,opt-flag t) + let-vars))) + (apply-p + (setf let-vars + (list* `(,opt-var (if ,apply-var + (pop ,apply-var) + ,opt-value)) + `(,opt-flag ,apply-var) + let-vars))) + (t + (setf let-vars + (list* `(,opt-var ,opt-value) + `(,opt-flag nil) + let-vars)))))) (when (or key-flag allow-other-keys) (unless rest - (setf rest (gensym)))) + (setf rest (gensym)))) (when rest (push `(,rest ,(if arguments - (if apply-p - `(list* ,@arguments ,apply-var) - `(list ,@arguments)) - (if apply-p apply-var nil))) - let-vars)) + (if apply-p + `(list* ,@arguments ,apply-var) + `(list ,@arguments)) + (if apply-p apply-var nil))) + let-vars)) (do ((scan (cdr keywords) (cddddr scan))) - ((endp scan)) + ((endp scan)) (let ((keyword (first scan)) - (key-var (second scan)) - (key-value (third scan)) - (key-flag (or (fourth scan) (gensym)))) - (push keyword all-keys) - (setf let-vars - (list* - `(,key-var (if (eq ,key-flag 'si::failed) ,key-value ,key-flag)) - `(,key-flag (si::search-keyword ,rest ,keyword)) - let-vars)) - (when (fourth scan) - (push `(setf ,key-flag (not (eq ,key-flag 'si::failed))) - extra-stmts)))) + (key-var (second scan)) + (key-value (third scan)) + (key-flag (or (fourth scan) (gensym)))) + (push keyword all-keys) + (setf let-vars + (list* + `(,key-var (if (eq ,key-flag 'si::failed) ,key-value ,key-flag)) + `(,key-flag (si::search-keyword ,rest ,keyword)) + let-vars)) + (when (fourth scan) + (push `(setf ,key-flag (not (eq ,key-flag 'si::failed))) + extra-stmts)))) (when (and key-flag (not allow-other-keys)) (push `(si::check-keyword ,rest ',all-keys) extra-stmts)) `(let* ,(nreverse (delete-if-not #'first let-vars)) ,@(multiple-value-bind (decl body) - (si::find-declarations (rest lambda-form)) - (append decl extra-stmts body))))) + (si::find-declarations (rest lambda-form)) + (append decl extra-stmts body))))) diff --git a/src/new-cmp/cmplet.lsp b/src/new-cmp/cmplet.lsp index 5b5ed7e08..21b5fa093 100644 --- a/src/new-cmp/cmplet.lsp +++ b/src/new-cmp/cmplet.lsp @@ -39,9 +39,9 @@ with extras = '() for (v . f) in compiled-pairs do (if (member (var-kind v) '(SPECIAL GLOBAL)) - (push v specials) - (push v locals)) - do (setf extras (nconc extras f)) + (push v specials) + (push v locals)) + do (setf extras (nconc extras f)) finally (return (nconc (c1bind locals) extras compiled-body diff --git a/src/new-cmp/cmploc.lsp b/src/new-cmp/cmploc.lsp index 27c615438..fa07c2298 100644 --- a/src/new-cmp/cmploc.lsp +++ b/src/new-cmp/cmploc.lsp @@ -15,81 +15,81 @@ (in-package "C-BACKEND") ;;; Valid locations are: -;;; NIL -;;; T -;;; fixnum -;;; VALUE0 -;;; VALUES -;;; VALUES+VALUE0 -;;; var-object -;;; ( VALUE i ) VALUES(i) -;;; ( VV vv-index ) -;;; ( VV-temp vv-index ) -;;; ( LCL lcl [representation-type]) local variable, type unboxed -;;; ( TEMP temp ) local variable, type object -;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments -;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed -;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function -;;; ( C-INLINE output-type fun/string locs side-effects output-var ) -;;; ( COERCE-LOC representation-type location) -;;; ( CAR lcl ) -;;; ( CDR lcl ) -;;; ( CADR lcl ) -;;; ( FDEFINITION vv-index ) -;;; ( MAKE-CCLOSURE cfun ) -;;; ( FIXNUM-VALUE fixnum-value ) -;;; ( CHARACTER-VALUE character-code ) -;;; ( LONG-FLOAT-VALUE long-float-value vv ) -;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) -;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) -;;; ( STACK-POINTER index ) retrieve a value from the stack -;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) -;;; ( KEYVARS n ) -;;; ( THE type loc ) -;;; VA-ARG -;;; CL-VA-ARG +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; VALUES+VALUE0 +;;; var-object +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-type]) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments +;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed +;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function +;;; ( C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( CAR lcl ) +;;; ( CDR lcl ) +;;; ( CADR lcl ) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( KEYVARS n ) +;;; ( THE type loc ) +;;; VA-ARG +;;; CL-VA-ARG ;;; Valid *DESTINATION* locations are: ;;; -;;; VALUE0 -;;; RETURN Object returned from current function. -;;; TRASH Value may be thrown away. -;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) -;;; ( JUMP-ZERO label ) -;;; ( JUMP-NONZERO label ) +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) +;;; ( JUMP-ZERO label ) +;;; ( JUMP-NONZERO label ) (in-package "C-DATA") (defun location-type (loc) (cond ((eq loc NIL) 'NULL) - ((var-p loc) (var-type loc)) - ((si::fixnump loc) 'fixnum) - ((atom loc) 'T) - (t - (case (first loc) - (FIXNUM-VALUE 'FIXNUM) - (CHARACTER-VALUE (type-of (code-char (second loc)))) - (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) - (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) - (LONG-FLOAT-VALUE 'LONG-FLOAT) - (C-INLINE (let ((type (first (second loc)))) + ((var-p loc) (var-type loc)) + ((si::fixnump loc) 'fixnum) + ((atom loc) 'T) + (t + (case (first loc) + (FIXNUM-VALUE 'FIXNUM) + (CHARACTER-VALUE (type-of (code-char (second loc)))) + (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) + (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) + (LONG-FLOAT-VALUE 'LONG-FLOAT) + (C-INLINE (let ((type (first (second loc)))) (cond ((and (consp type) (eq (first type) 'VALUES)) T) ((c-backend::lisp-type-p type) type) (t (c-backend::rep-type->lisp-type type))))) - (BIND (var-type (second loc))) - (LCL (or (third loc) T)) + (BIND (var-type (second loc))) + (LCL (or (third loc) T)) (MAKE-CCLOSURE 'FUNCTION) ((VV VV-TEMP) (if (cddr loc) (type-of (third loc)) T)) - (otherwise T))))) + (otherwise T))))) (defun location-primary-type (loc) (location-type loc)) diff --git a/src/new-cmp/cmpmain.lsp b/src/new-cmp/cmpmain.lsp index d9e50da55..9513dcebe 100644 --- a/src/new-cmp/cmpmain.lsp +++ b/src/new-cmp/cmpmain.lsp @@ -24,8 +24,8 @@ (let ((result (si:system string))) (unless (zerop result) (cerror "Continues anyway." - "(SYSTEM ~S) returned non-zero value ~D" - string result)) + "(SYSTEM ~S) returned non-zero value ~D" + string result)) result)) (defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p) @@ -49,27 +49,27 @@ (:import-library (setf extension "implib")) ((:fasl :fas) (setf extension "fas"))) (cond ((not (member output-file '(T NIL))) - output-file) - (format - (merge-pathnames (format nil format (pathname-name name)) name)) - (t - (make-pathname :type extension :defaults name))))) + output-file) + (format + (merge-pathnames (format nil format (pathname-name name)) name)) + (t + (make-pathname :type extension :defaults name))))) #+msvc (defun delete-msvc-generated-files (output-pathname) (loop for i in '("lib" "exp" "ilk" "pdb") do (let ((the-pathname (merge-pathnames (make-pathname :type i) output-pathname))) - (when (probe-file the-pathname) - (cmp-delete-file the-pathname))))) + (when (probe-file the-pathname) + (cmp-delete-file the-pathname))))) (defun cmp-delete-file (file) (cond ((null *delete-files*)) - (*debug-compiler* - (cmpprogress "~%Postponing deletion of ~A" file) - (push file *files-to-be-deleted*)) - (t - (and (probe-file file) - (delete-file file))))) + (*debug-compiler* + (cmpprogress "~%Postponing deletion of ~A" file) + (push file *files-to-be-deleted*)) + (t + (and (probe-file file) + (delete-file file))))) (push #'(lambda () (mapc #'delete-file *files-to-be-deleted*)) si::*exit-hooks*) @@ -86,60 +86,60 @@ (defun linker-cc (o-pathname &rest options) (safe-system (format nil - *ld-format* - *ld* - (si::coerce-to-filename o-pathname) - (fix-for-mingw (ecl-library-directory)) - options - *ld-flags*))) + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-flags*))) #+dlopen (defun shared-cc (o-pathname &rest options) #-(or mingw32) (safe-system (format nil - *ld-format* - *ld* - (si::coerce-to-filename o-pathname) - (fix-for-mingw (ecl-library-directory)) - options - *ld-shared-flags*)) + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-shared-flags*)) #+(or mingw32) (let ((lib-file (compile-file-pathname o-pathname :type :lib))) (safe-system (format nil - "gcc -shared -o ~S -L~S ~{~S ~} ~@?" - (si::coerce-to-filename o-pathname) - (fix-for-mingw (ecl-library-directory)) - options - *ld-shared-flags*)))) + "gcc -shared -o ~S -L~S ~{~S ~} ~@?" + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-shared-flags*)))) #+dlopen (defun bundle-cc (o-pathname init-name &rest options) #-(or mingw32) (safe-system (format nil - *ld-format* - *ld* - (si::coerce-to-filename o-pathname) - (fix-for-mingw (ecl-library-directory)) - options - #-msvc *ld-bundle-flags* - #+msvc (concatenate 'string *ld-bundle-flags* - " /EXPORT:" init-name - " /LIBPATH:" (ecl-library-directory) - " /IMPLIB:" - (si::coerce-to-filename - (compile-file-pathname - o-pathname :type :import-library))))) + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + #-msvc *ld-bundle-flags* + #+msvc (concatenate 'string *ld-bundle-flags* + " /EXPORT:" init-name + " /LIBPATH:" (ecl-library-directory) + " /IMPLIB:" + (si::coerce-to-filename + (compile-file-pathname + o-pathname :type :import-library))))) #+(or mingw32) (safe-system (format nil - "gcc -shared -o ~A -Wl,--export-all-symbols -L~S ~{~S ~} ~@?" - (si::coerce-to-filename o-pathname) - (fix-for-mingw (ecl-library-directory)) - options - *ld-bundle-flags*))) + "gcc -shared -o ~A -Wl,--export-all-symbols -L~S ~{~S ~} ~@?" + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-bundle-flags*))) (defconstant +lisp-program-header+ " #include @@ -150,7 +150,7 @@ #define ECL_CPP_TAG #endif -~{ extern ECL_CPP_TAG void ~A(cl_object);~%~} +~{ extern ECL_CPP_TAG void ~A(cl_object);~%~} ") @@ -170,38 +170,38 @@ extern \"C\" #endif void ~A(cl_object cblock) { - static cl_object Cblock; + static cl_object Cblock; if (!FIXNUMP(cblock)) { - Cblock = cblock; - cblock->cblock.data_text = compiler_data_text; - cblock->cblock.data_text_size = compiler_data_text_size; + Cblock = cblock; + cblock->cblock.data_text = compiler_data_text; + cblock->cblock.data_text_size = compiler_data_text_size; #ifndef ECL_DYNAMIC_VV - cblock->cblock.data = VV; + cblock->cblock.data = VV; #endif - cblock->cblock.data_size = VM; - return; - } + cblock->cblock.data_size = VM; + return; + } #if defined(ECL_DYNAMIC_VV) && defined(ECL_SHARED_DATA) - VV = Cblock->cblock.data; + VV = Cblock->cblock.data; #endif - ~A + ~A { - cl_object current, next = Cblock; -~:[~{ current = read_VV(OBJNULL, ~A); current->cblock.next = next; next = current; ~%~} - Cblock->cblock.next = current; -~;~{ ~A(Cblock);~%~}~] + cl_object current, next = Cblock; +~:[~{ current = read_VV(OBJNULL, ~A); current->cblock.next = next; next = current; ~%~} + Cblock->cblock.next = current; +~;~{ ~A(Cblock);~%~}~] } - ~A + ~A }") (defconstant +lisp-program-main+ " int main(int argc, char **argv) { - ~A - cl_boot(argc, argv); - read_VV(OBJNULL, ~A); - ~A + ~A + cl_boot(argc, argv); + read_VV(OBJNULL, ~A); + ~A }") #+:win32 @@ -210,32 +210,32 @@ main(int argc, char **argv) int WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) { - char **argv; - int argc; - ~A - ecl_get_commandline_args(&argc, &argv); - cl_boot(argc, argv); - read_VV(OBJNULL, ~A); - ~A + char **argv; + int argc; + ~A + ecl_get_commandline_args(&argc, &argv); + cl_boot(argc, argv); + read_VV(OBJNULL, ~A); + ~A }") (defun guess-kind (pathname) "Given a file name, guess whether it is an object file, a library, a program or a loadable module." (let ((record (assoc (pathname-type pathname) - '(("o" :object) ("obj" :object) ("c" :c) - ("lib" :static-library) - ("a" :static-library) - ("dll" :shared-library) - ("so" :shared-library) - ("fas" :fasl)) - :test #'string-equal))) + '(("o" :object) ("obj" :object) ("c" :c) + ("lib" :static-library) + ("a" :static-library) + ("dll" :shared-library) + ("so" :shared-library) + ("fas" :fasl)) + :test #'string-equal))) (if record - (second record) - (progn - (warn "File ~s is of no known file type. Assuming it is an object file." - pathname) - :object)))) + (second record) + (progn + (warn "File ~s is of no known file type. Assuming it is an object file." + pathname) + :object)))) (defun guess-ld-flags (pathname &key (kind (guess-kind pathname))) "Given a file name, return the compiler command line argument to link this file in." @@ -276,20 +276,20 @@ filesystem or in the database of ASDF modules." (fallback))))) (defun builder (target output-name &key lisp-files ld-flags shared-data-file - (init-name nil) - (prologue-code "") - (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL))) - #+:win32 (system :console) - &aux - (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*)))) + (init-name nil) + (prologue-code "") + (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL))) + #+:win32 (system :console) + &aux + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*)))) ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) ;; ;; The epilogue-code can be either a string made of C code, or a @@ -298,24 +298,24 @@ filesystem or in the database of ASDF modules." ;; to avoid using the compiler. ;; (cond ((null epilogue-code) - (setf epilogue-code "")) - ((stringp epilogue-code) - ) - (t - (with-standard-io-syntax - (setq epilogue-code - (with-output-to-string (stream) - (princ "{ const char *lisp_code = " stream) - (wt-filtered-data (write-to-string epilogue-code) stream) - (princ "; + (setf epilogue-code "")) + ((stringp epilogue-code) + ) + (t + (with-standard-io-syntax + (setq epilogue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string epilogue-code) stream) + (princ "; cl_object output; si_select_package(ecl_make_simple_base_string(\"CL-USER\",7)); output = cl_safe_eval(c_string_to_object(lisp_code), Cnil, OBJNULL); " stream) - (when (eq target :program) - (princ "cl_shutdown(); return (output != OBJNULL);" stream)) - (princ #\} stream) - ))))) + (when (eq target :program) + (princ "cl_shutdown(); return (output != OBJNULL);" stream)) + (princ #\} stream) + ))))) ;; ;; When a module is built out of several object files, we have to ;; create an additional object file that initializes those ones. @@ -325,34 +325,34 @@ output = cl_safe_eval(c_string_to_object(lisp_code), Cnil, OBJNULL); ;; file name (tmp-name). ;; (let* ((tmp-name (si::mkstemp #P"TMP:ECLINIT")) - (c-name (si::coerce-to-filename - (compile-file-pathname tmp-name :type :c))) - (o-name (si::coerce-to-filename - (compile-file-pathname tmp-name :type :object))) - submodules - c-file) + (c-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :c))) + (o-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :object))) + submodules + c-file) (dolist (item (reverse lisp-files)) (etypecase item (symbol (push (system-ld-flag item) ld-flags) (push (init-function-name item :kind :lib) submodules)) ((or string pathname) - (let* ((pathname (parse-namestring item)) - (kind (guess-kind pathname))) - (unless (member kind '(:shared-library :dll :static-library :lib - :object :c)) - (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) - (let* ((path (parse-namestring item)) - (init-fn (guess-init-name path (guess-kind path))) - (flags (guess-ld-flags path))) - ;; We should give a warning that we cannot link this module in - (when flags (push flags ld-flags)) - (push init-fn submodules)))))) + (let* ((pathname (parse-namestring item)) + (kind (guess-kind pathname))) + (unless (member kind '(:shared-library :dll :static-library :lib + :object :c)) + (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) + (let* ((path (parse-namestring item)) + (init-fn (guess-init-name path (guess-kind path))) + (flags (guess-ld-flags path))) + ;; We should give a warning that we cannot link this module in + (when flags (push flags ld-flags)) + (push init-fn submodules)))))) (setq c-file (open c-name :direction :output :external-format :default)) (format c-file +lisp-program-header+ submodules) (cond (shared-data-file - (data-init shared-data-file) - (format c-file " + (data-init shared-data-file) + (format c-file " #define VM ~A #ifdef ECL_DYNAMIC_VV static cl_object *VV; @@ -361,9 +361,9 @@ static cl_object VV[VM]; #endif #define ECL_SHARED_DATA_FILE 1 " (data-permanent-storage-size)) - (c-backend::data-dump c-file)) - (t - (format c-file " + (c-backend::data-dump c-file)) + (t + (format c-file " #define compiler_data_text NULL #define compiler_data_text_size 0 #define VV NULL @@ -375,24 +375,24 @@ static cl_object VV[VM]; (ecase target (:program (format c-file +lisp-program-init+ init-name "" shared-data-file - submodules "") + submodules "") (format c-file #+:win32 (ecase system (:console +lisp-program-main+) - (:windows +lisp-program-winmain+)) - #-:win32 +lisp-program-main+ - prologue-code init-name epilogue-code) + (:windows +lisp-program-winmain+)) + #-:win32 +lisp-program-main+ + prologue-code init-name epilogue-code) (close c-file) (compiler-cc c-name o-name) (apply #'linker-cc output-name (namestring o-name) ld-flags)) ((:library :static-library :lib) (format c-file +lisp-program-init+ init-name prologue-code - shared-data-file submodules epilogue-code) + shared-data-file submodules epilogue-code) (close c-file) (compiler-cc c-name o-name) (when (probe-file output-name) (delete-file output-name)) #-msvc (progn (safe-system (format nil "ar cr ~A ~A ~{~A ~}" - output-name o-name ld-flags)) + output-name o-name ld-flags)) (safe-system (format nil "ranlib ~A" output-name))) #+msvc (unwind-protect @@ -407,14 +407,14 @@ static cl_object VV[VM]; #+dlopen ((:shared-library :dll) (format c-file +lisp-program-init+ init-name prologue-code - shared-data-file submodules epilogue-code) + shared-data-file submodules epilogue-code) (close c-file) (compiler-cc c-name o-name) (apply #'shared-cc output-name o-name ld-flags)) #+dlopen (:fasl (format c-file +lisp-program-init+ init-name prologue-code shared-data-file - submodules epilogue-code) + submodules epilogue-code) (close c-file) (compiler-cc c-name o-name) (apply #'bundle-cc output-name init-name o-name ld-flags))) @@ -440,29 +440,29 @@ static cl_object VV[VM]; (defun compile-file (input-pathname &rest args &key - ((:verbose *compile-verbose*) *compile-verbose*) - ((:print *compile-print*) *compile-print*) + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) (source-truename nil) (source-offset 0) - (c-file nil) - (h-file nil) - (data-file nil) - (shared-data-file nil) - (system-p nil) - (load nil) + (c-file nil) + (h-file nil) + (data-file nil) + (shared-data-file nil) + (system-p nil) + (load nil) (external-format :default) - output-file + output-file &aux (*standard-output* *standard-output*) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*package* *package*) - (*print-pretty* nil) - (*compile-file-pathname* nil) - (*compile-file-truename* nil) + (*print-pretty* nil) + (*compile-file-pathname* nil) + (*compile-file-truename* nil) (ext:*source-location* (cons source-truename 0)) - (*suppress-compiler-messages* - (or *suppress-compiler-messages* (not *compile-verbose*))) - init-name) + (*suppress-compiler-messages* + (or *suppress-compiler-messages* (not *compile-verbose*))) + init-name) (declare (notinline compiler-cc)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, @@ -474,10 +474,10 @@ compiled successfully, returns the pathname of the compiled file" ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) #-dlopen (unless system-p @@ -489,12 +489,12 @@ compiled successfully, returns the pathname of the compiled file" (setq *compile-file-pathname* (pathname (merge-pathnames input-pathname))) (unless (probe-file *compile-file-pathname*) (if (pathname-type input-pathname) - (error 'file-error :pathname input-pathname) - (dolist (ext '("lsp" "LSP" "lisp" "LISP") - (error 'file-error :pathname input-pathname)) - (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) - (when (probe-file *compile-file-pathname*) - (return))))) + (error 'file-error :pathname input-pathname) + (dolist (ext '("lsp" "LSP" "lisp" "LISP") + (error 'file-error :pathname input-pathname)) + (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) + (when (probe-file *compile-file-pathname*) + (return))))) (setq input-file (truename *compile-file-pathname*) *compile-file-truename* input-file) @@ -504,8 +504,8 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname)) (let* ((eof '(NIL)) - (*compiler-in-use* *compiler-in-use*) - (*load-time-values* nil) ;; Load time values are compiled + (*compiler-in-use* *compiler-in-use*) + (*load-time-values* nil) ;; Load time values are compiled (output-file (apply #'compile-file-pathname input-file args)) (true-output-file nil) ;; Will be set at the end (c-pathname (apply #'compile-file-pathname output-file :output-file c-file @@ -514,9 +514,9 @@ compiled successfully, returns the pathname of the compiled file" :type :h args)) (data-pathname (apply #'compile-file-pathname output-file :output-file data-file :type :data args)) - (shared-data-pathname (apply #'compile-file-pathname output-file + (shared-data-pathname (apply #'compile-file-pathname output-file :output-file shared-data-file :type :sdata args)) - (compiler-conditions nil) + (compiler-conditions nil) (to-delete (nconc (unless c-file (list c-pathname)) (unless h-file (list h-pathname)) (unless (or data-file shared-data-file) @@ -527,17 +527,17 @@ compiled successfully, returns the pathname of the compiled file" (print-compiler-info) (when (probe-file "./cmpinit.lsp") - (load "./cmpinit.lsp" :verbose *compile-verbose*)) + (load "./cmpinit.lsp" :verbose *compile-verbose*)) (if shared-data-file - (if system-p - (data-init shared-data-pathname) - (error "Shared data files are only allowed when compiling ~& - with the flag :SYSTEM-P set to T.")) - (data-init)) + (if system-p + (data-init shared-data-pathname) + (error "Shared data files are only allowed when compiling ~& + with the flag :SYSTEM-P set to T.")) + (data-init)) (setf init-name (compute-init-name output-file :kind - (if system-p :object :fasl))) + (if system-p :object :fasl))) (with-t1expr (init-name) (with-open-file (*compiler-input* *compile-file-pathname* @@ -555,13 +555,13 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;; End of Pass 1.") (compiler-pass2 c-pathname h-pathname data-pathname system-p - init-name - shared-data-file + init-name + shared-data-file :input-designator (namestring input-pathname)) (if shared-data-file - (c-backend::data-dump shared-data-pathname t) - (c-backend::data-dump data-pathname)) + (c-backend::data-dump shared-data-pathname t) + (c-backend::data-dump data-pathname)) (let ((o-pathname (if system-p output-file @@ -582,7 +582,7 @@ compiled successfully, returns the pathname of the compiled file" (mapc #'cmp-delete-file to-delete) (when (and load true-output-file (not system-p)) - (load true-output-file :verbose *compile-verbose*)) + (load true-output-file :verbose *compile-verbose*)) ) ; with-compiler-env @@ -593,9 +593,9 @@ compiled successfully, returns the pathname of the compiled file" with warning-p = nil with failure-p = nil do (cond ((typep i 'style-warning) - (setf warning-p t)) - ((typep i '(or compiler-error warning)) - (setf warning-p t failure-p t))) + (setf warning-p t)) + ((typep i '(or compiler-error warning)) + (setf warning-p t failure-p t))) finally (return (values main-value warning-p failure-p)))) #-dlopen @@ -612,14 +612,14 @@ compiled successfully, returns the pathname of the compiled file" (defun compile (name &optional (def nil supplied-p) &aux form data-pathname (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*))) + (not *compile-verbose*))) (*compiler-in-use* *compiler-in-use*) (*standard-output* *standard-output*) (*error-output* *error-output*) (*package* *package*) (*compile-print* nil) - (*print-pretty* nil) - (*compiler-constants* t)) + (*print-pretty* nil) + (*compiler-constants* t)) "Args: (name &optional definition) If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. @@ -637,46 +637,46 @@ after compilation." ;; Deprecated, to be removed in next release (when *suppress-compiler-notes* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-note))) + `(or ,*suppress-compiler-messages* compiler-note))) (when *suppress-compiler-warnings* (setf *suppress-compiler-messages* - `(or ,*suppress-compiler-messages* compiler-warning))) + `(or ,*suppress-compiler-messages* compiler-warning))) (cond ((and supplied-p def) - (when (functionp def) - (unless (function-lambda-expression def) - (return-from compile def)) - (setf def (function-lambda-expression def))) + (when (functionp def) + (unless (function-lambda-expression def) + (return-from compile def)) + (setf def (function-lambda-expression def))) (setq form (if name `(setf (symbol-function ',name) #',def) `(set 'GAZONK #',def)))) - ((not (fboundp name)) - (error "Symbol ~s is unbound." name)) - ((typep (setf def (symbol-function name)) 'standard-generic-function) - (warn "COMPILE can not compile generic functions yet") - (return-from compile (values def t nil))) - ((null (setq form (function-lambda-expression def))) - (warn "We have lost the original function definition for ~s. Compilation to C failed" + ((not (fboundp name)) + (error "Symbol ~s is unbound." name)) + ((typep (setf def (symbol-function name)) 'standard-generic-function) + (warn "COMPILE can not compile generic functions yet") + (return-from compile (values def t nil))) + ((null (setq form (function-lambda-expression def))) + (warn "We have lost the original function definition for ~s. Compilation to C failed" name) - (return-from compile (values def t nil))) - (t - (setq form `(setf (symbol-function ',name) #',form)))) + (return-from compile (values def t nil))) + (t + (setq form `(setf (symbol-function ',name) #',form)))) (let ((template (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) (unless (setq data-pathname (si::mkstemp template)) (error "Unable to create temporay file~%~ - ~AXXXXXX + ~AXXXXXX Make sure you have enough free space in disk, check permissions or set~%~ the environment variable TMPDIR to a different value." template) (return-from compile (values nil t t)))) (let*((*load-time-values* 'values) ;; Only the value is kept - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) - (compiler-conditions nil)) + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil)) (with-compiler-env (compiler-conditions) (print-compiler-info) @@ -685,33 +685,33 @@ the environment variable TMPDIR to a different value." template) (t1expr form)) (cmpprogress "~&;;; End of Pass 1.") (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) - (compiler-pass2 c-pathname h-pathname data-pathname nil - init-name nil + (compiler-pass2 c-pathname h-pathname data-pathname nil + init-name nil :input-designator (format nil "~A" def))) (setf *compiler-constants* (c-backend::data-dump data-pathname)) (compiler-cc c-pathname o-pathname) (bundle-cc (si::coerce-to-filename so-pathname) - init-name - (si::coerce-to-filename o-pathname)) + init-name + (si::coerce-to-filename o-pathname)) (cmp-delete-file c-pathname) (cmp-delete-file h-pathname) (cmp-delete-file o-pathname) (cmp-delete-file data-pathname) (cond ((probe-file so-pathname) - (load so-pathname :verbose nil) - #-(or mingw32 msvc cygwin) - (cmp-delete-file so-pathname) - #+msvc - (delete-msvc-generated-files so-pathname) - (setf name (or name (symbol-value 'GAZONK))) - ;; By unsetting GAZONK we avoid spurious references to the - ;; loaded code. - (set 'GAZONK nil) - (si::gc t) - (values name nil nil)) - (t - (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) + (load so-pathname :verbose nil) + #-(or mingw32 msvc cygwin) + (cmp-delete-file so-pathname) + #+msvc + (delete-msvc-generated-files so-pathname) + (setf name (or name (symbol-value 'GAZONK))) + ;; By unsetting GAZONK we avoid spurious references to the + ;; loaded code. + (set 'GAZONK nil) + (si::gc t) + (values name nil nil)) + (t + (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) ) ; with-compiler-env (when (probe-file c-pathname) (cmp-delete-file c-pathname)) @@ -723,9 +723,9 @@ the environment variable TMPDIR to a different value." template) (compiler-output-values name compiler-conditions))) (defun disassemble (thing &key (h-file nil) (data-file nil) - &aux def disassembled-form - (*compiler-in-use* *compiler-in-use*) - (*print-pretty* nil)) + &aux def disassembled-form + (*compiler-in-use* *compiler-in-use*) + (*print-pretty* nil)) "Compiles the form specified by THING and prints the intermediate C language code for that form. But does not install the result of compilation. If THING is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd. If THING is @@ -737,55 +737,55 @@ from the C language code. NIL means \"do not create the file\"." (when (si::valid-function-name-p thing) (setq thing (fdefinition thing))) (cond ((null thing)) - ((functionp thing) - (unless (si::bc-disassemble thing) - (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) - (return-from disassemble nil))) - ((atom thing) - (error 'simple-type-error - :datum thing - :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" - :format-arguments (list thing))) - ((eq (car thing) 'LAMBDA) - (setq disassembled-form `(defun gazonk ,@(cdr thing)))) - ((eq (car thing) 'EXT:LAMBDA-BLOCK) - (setq disassembled-form `(defun ,@(rest thing)))) - (t - (error 'simple-type-error - :datum thing - :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" - :format-arguments (list thing)))) + ((functionp thing) + (unless (si::bc-disassemble thing) + (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) + (return-from disassemble nil))) + ((atom thing) + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing))) + ((eq (car thing) 'LAMBDA) + (setq disassembled-form `(defun gazonk ,@(cdr thing)))) + ((eq (car thing) 'EXT:LAMBDA-BLOCK) + (setq disassembled-form `(defun ,@(rest thing)))) + (t + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing)))) (let* ((null-stream (make-broadcast-stream)) (*compiler-output1* null-stream) (*compiler-output2* (if h-file - (open h-file :direction :output :external-format :default) - null-stream)) + (open h-file :direction :output :external-format :default) + null-stream)) (t3local-fun (symbol-function 'c-backend::t3local-fun)) - (compiler-conditions nil) + (compiler-conditions nil) (init-name (compute-init-name "foo" :kind :fasl))) (with-compiler-env (compiler-conditions) (unwind-protect - (progn - (setf (symbol-function 'c-backend::t3local-fun) - #'(lambda (&rest args) - (let ((*compiler-output1* *standard-output*)) - (apply t3local-fun args)))) - (data-init) + (progn + (setf (symbol-function 'c-backend::t3local-fun) + #'(lambda (&rest args) + (let ((*compiler-output1* *standard-output*)) + (apply t3local-fun args)))) + (data-init) (with-t1expr (init-name) (t1expr disassembled-form)) - (c-backend::ctop-write init-name + (c-backend::ctop-write init-name (if h-file h-file "") (if data-file data-file "")) - (c-backend::data-dump data-file)) - (setf (symbol-function 'c-backend::t3local-fun) t3local-fun) - (when h-file (close *compiler-output2*))))) + (c-backend::data-dump data-file)) + (setf (symbol-function 'c-backend::t3local-fun) t3local-fun) + (when h-file (close *compiler-output2*))))) nil) (defun compiler-pass2 (c-pathname h-pathname data-pathname system-p init-name - shared-data &key input-designator) + shared-data &key input-designator) (with-open-file (*compiler-output1* c-pathname :direction :output) (with-open-file (*compiler-output2* h-pathname :direction :output) (catch *cmperr-tag* (c-backend::ctop-write init-name @@ -799,45 +799,45 @@ from the C language code. NIL means \"do not create the file\"." (defun ecl-include-directory () "Finds the directory in which the header files were installed." (cond ((and *ecl-include-directory* - (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) - *ecl-include-directory*) - ((probe-file "SYS:ecl;config.h") - (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find include directory")))) + (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) + *ecl-include-directory*) + ((probe-file "SYS:ecl;config.h") + (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find include directory")))) (defun ecl-library-directory () "Finds the directory in which the ECL core library was installed." (cond ((and *ecl-library-directory* - (probe-file (merge-pathnames (compile-file-pathname "ecl" :type - #+dlopen :shared-library - #-dlopen :static-library) - *ecl-library-directory*))) - *ecl-library-directory*) - ((probe-file "SYS:BUILD-STAMP") - (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find library directory")))) + (probe-file (merge-pathnames (compile-file-pathname "ecl" :type + #+dlopen :shared-library + #-dlopen :static-library) + *ecl-library-directory*))) + *ecl-library-directory*) + ((probe-file "SYS:BUILD-STAMP") + (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find library directory")))) (defun compiler-cc (c-pathname o-pathname) (safe-system (format nil - *cc-format* - *cc* *cc-flags* (>= (cmp-env-optimization 'speed) 2) *cc-optimize* - (fix-for-mingw (ecl-include-directory)) - (si::coerce-to-filename c-pathname) - (si::coerce-to-filename o-pathname)) + *cc-format* + *cc* *cc-flags* (>= (cmp-env-optimization 'speed) 2) *cc-optimize* + (fix-for-mingw (ecl-include-directory)) + (si::coerce-to-filename c-pathname) + (si::coerce-to-filename o-pathname)) ; Since the SUN4 assembler loops with big files, you might want to use this: ; (format nil -; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" -; *cc* (>= *speed* 2) +; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" +; *cc* (>= *speed* 2) ; *include-directory* -; (namestring c-pathname) -; (namestring o-pathname) -; (namestring s-pathname)) +; (namestring c-pathname) +; (namestring o-pathname) +; (namestring s-pathname)) )) (defun print-compiler-info () (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%" - *safety* *space* *speed* *debug*)) + *safety* *space* *speed* *debug*)) (defmacro with-compilation-unit (options &rest body) `(progn ,@body)) diff --git a/src/new-cmp/cmpmap.lsp b/src/new-cmp/cmpmap.lsp index db8194cc9..c08bb2ffd 100644 --- a/src/new-cmp/cmpmap.lsp +++ b/src/new-cmp/cmpmap.lsp @@ -22,38 +22,38 @@ (let ((which (first whole))) (when (eq which 'FUNCALL) (setf whole (rest whole) - which (first whole)) + which (first whole)) (when (consp which) - (if (eq (first which) 'FUNCTION) - (setf which (second which)) - (return-from expand-mapcar whole)))) + (if (eq (first which) 'FUNCTION) + (setf which (second which)) + (return-from expand-mapcar whole)))) (let* ((function (second whole)) - (args (cddr whole)) - iterators for-statements - (in-or-on :IN) - (do-or-collect :COLLECT) - (list-1-form nil) - (finally-form nil)) + (args (cddr whole)) + iterators for-statements + (in-or-on :IN) + (do-or-collect :COLLECT) + (list-1-form nil) + (finally-form nil)) (case which - (MAPCAR) - (MAPLIST (setf in-or-on :ON)) - (MAPC (setf do-or-collect :DO)) - (MAPL (setf in-or-on :ON do-or-collect :DO)) - (MAPCAN (setf do-or-collect 'NCONC)) - (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) + (MAPCAR) + (MAPLIST (setf in-or-on :ON)) + (MAPC (setf do-or-collect :DO)) + (MAPL (setf in-or-on :ON do-or-collect :DO)) + (MAPCAN (setf do-or-collect 'NCONC)) + (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) (when (eq do-or-collect :DO) - (let ((var (gensym))) - (setf list-1-form `(with ,var = ,(first args)) - args (list* var (rest args)) - finally-form `(finally (return ,var))))) + (let ((var (gensym))) + (setf list-1-form `(with ,var = ,(first args)) + args (list* var (rest args)) + finally-form `(finally (return ,var))))) (loop for arg in (reverse args) - do (let ((var (gensym))) - (setf iterators (cons var iterators) - for-statements (list* :for var in-or-on arg for-statements)))) + do (let ((var (gensym))) + (setf iterators (cons var iterators) + for-statements (list* :for var in-or-on arg for-statements)))) `(loop ,@list-1-form - ,@for-statements - ,do-or-collect (funcall ,function ,@iterators) - ,@finally-form)))) + ,@for-statements + ,do-or-collect (funcall ,function ,@iterators) + ,@finally-form)))) (define-compiler-macro mapcar (&whole whole &rest r) (expand-mapcar whole)) diff --git a/src/new-cmp/cmpmulti.lsp b/src/new-cmp/cmpmulti.lsp index c7ba1c9c9..06c2bd630 100644 --- a/src/new-cmp/cmpmulti.lsp +++ b/src/new-cmp/cmpmulti.lsp @@ -23,8 +23,8 @@ ((endp (rest args)) (c1funcall destination args)) ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) ((and (= (length args) 2) - (consp (setq forms (second args))) - (eq 'VALUES (first forms))) + (consp (setq forms (second args))) + (eq 'VALUES (first forms))) (c1funcall destination (list* (first args) (rest forms)))) ;; More complicated case. (t @@ -80,30 +80,30 @@ (defun c1multiple-value-setq (destination args &aux (vars nil) (temp-vars nil) - (late-bindings nil)) + (late-bindings nil)) (check-args-number 'MULTIPLE-VALUE-SETQ args 2 2) (dolist (var (reverse (first args))) (cmpck (not (symbolp var)) "The variable ~s is not a symbol." var) (setq var (chk-symbol-macrolet var)) (cond ((symbolp var) - (cmpck (constantp var) - "The constant ~s is being assigned a value." var) - (push var vars)) - (t (let ((new-var (gensym))) - (push new-var vars) - (push new-var temp-vars) - (push `(setf ,var ,new-var) late-bindings))))) + (cmpck (constantp var) + "The constant ~s is being assigned a value." var) + (push var vars)) + (t (let ((new-var (gensym))) + (push new-var vars) + (push new-var temp-vars) + (push `(setf ,var ,new-var) late-bindings))))) (let ((value (second args))) (cond (temp-vars - (c1translate destination + (c1translate destination `(let* (,@temp-vars) (multiple-value-setq ,vars ,value) ,@late-bindings))) - ((endp vars) - (c1translate destination `(values ,value))) - ((= (length vars) 1) - (c1translate destination `(setq ,(first vars) ,value))) - (t + ((endp vars) + (c1translate destination `(values ,value))) + ((= (length vars) 1) + (c1translate destination `(setq ,(first vars) ,value))) + (t (setf vars (mapcar #'c1vref vars)) (nconc (c1translate 'VALUES value) (c1set-mv vars) diff --git a/src/new-cmp/cmpnum.lsp b/src/new-cmp/cmpnum.lsp index 66e5e44d6..508893132 100644 --- a/src/new-cmp/cmpnum.lsp +++ b/src/new-cmp/cmpnum.lsp @@ -149,8 +149,8 @@ (def-type-propagator expt (fname base exponent) ;; Rules: - ;; (expt number-type integer) -> number-type - ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) + ;; (expt number-type integer) -> number-type + ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) ;; (multiple-value-bind (simplified-exponent exponent) (ensure-real-type exponent) diff --git a/src/new-cmp/cmppackage.lsp b/src/new-cmp/cmppackage.lsp index 02aa73079..9e9de95c5 100644 --- a/src/new-cmp/cmppackage.lsp +++ b/src/new-cmp/cmppackage.lsp @@ -20,14 +20,14 @@ (:nicknames "COMPILER-DATA") (:use "FFI" "CL") (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" - "*CC*" - "*CC-OPTIMIZE*" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-MESSAGES*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*CC*" + "*CC-OPTIMIZE*" + "*SUPPRESS-COMPILER-WARNINGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-MESSAGES*" "PROCLAIMED-ARG-TYPES" "PROCLAIMED-RETURN-TYPE" "NO-SP-CHANGE" @@ -217,30 +217,30 @@ (:nicknames "COMPILER") (:use "FFI" "CL" "C-TAGS" "C-TYPES" "C-LOG" "C-BACKEND" "C-ENV" "C-DATA") (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" - "*CC*" - "*CC-OPTIMIZE*" - "BUILD-ECL" - "BUILD-PROGRAM" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*CC*" + "*CC-OPTIMIZE*" + "BUILD-ECL" + "BUILD-PROGRAM" "BUILD-FASL" - "BUILD-STATIC-LIBRARY" - "BUILD-SHARED-LIBRARY" - "COMPILER-WARNING" - "COMPILER-NOTE" - "COMPILER-MESSAGE" - "COMPILER-ERROR" - "COMPILER-FATAL-ERROR" - "COMPILER-INTERNAL-ERROR" - "COMPILER-UNDEFINED-VARIABLE" - "COMPILER-MESSAGE-FILE" - "COMPILER-MESSAGE-FILE-POSITION" - "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-MESSAGES*") + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" + "*SUPPRESS-COMPILER-WARNINGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-MESSAGES*") (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" - "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" - "COMPILER-LET")) + "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" + "COMPILER-LET")) diff --git a/src/new-cmp/cmppass.lsp b/src/new-cmp/cmppass.lsp index 2c028e33d..5cceeed36 100644 --- a/src/new-cmp/cmppass.lsp +++ b/src/new-cmp/cmppass.lsp @@ -15,48 +15,48 @@ ;;; ;;; ALL C1FORMS ;;; -;;; BIND (var1 ... varN) -;;; BIND-REQUIREDS ((var1 . arg1-loc) ... (varN . argN-loc)) -;;; BIND-SPECIAL destination value-loc -;;; CALL-LOCAL destination fun (arg1 ... argN) -;;; CALL-GLOBAL destination fun (arg1 ... argN) -;;; C-INLINE -;;; DEBUG-ENV-OPEN fun-name -;;; DEBUG-ENV-PUSH-VARS (var1 ... varN) -;;; DEBUG-ENV-POP-VARS (var1 ... varN) close-block -;;; DEBUG-ENV-CLOSE fun-name -;;; DO-FLET/LABELS (fun1 ... funN) -;;; FRAME-ID frame-var -;;; FRAME-JMP-NEXT frame-var -;;; FRAME-POP frame-var -;;; FRAME-SAVE-NEXT frame-var -;;; FRAME-SET id-loc no-label -;;; FUNCALL destination (arg1 ... argN) -;;; FUNCTION-PROLOGUE fun -;;; FUNCTION-EPILOGUE fun -;;; GO tag -;;; JMP tag -;;; PROGV ndx-loc (var1-loc ... varN-loc) values-loc -;;; PROGV-EXIT ndx-loc -;;; SET destination source -;;; SET-MV (dest-loc1 ... dest-locN) min-args max-args -;;; SI:STRUCTURE-REF -;;; SI:STRUCTURE-SET -;;; STACK-FRAME-OPEN frame-var -;;; STACK-FRAME-PUSH frame-var value-loc -;;; STACK-FRAME-PUSH-VALUES frame-var -;;; STACK-FRAME-POP-VALUES frame-var -;;; STACK-FRAME-APPLY frame-var fun-loc -;;; STACK-FRAME-CLOSE frame-var -;;; RETURN-FROM block-id-var block-name -;;; THROW tag-loc -;;; UNBIND (var1 ... varN) -;;; VALUES (value1-loc ... valueN-loc) -;;; VARARGS-BIND nargs-loc varargs-loc min max nkeys check -;;; VARARGS-POP dest-loc nargs-loc varargs-loc -;;; VARARGS-REST dest-loc nargs-loc varargs-loc nkeys -;;; keys-list-loc allow-other-keys -;;; VARARGS-UNBIND nargs-loc varargs-loc min max nkeys check +;;; BIND (var1 ... varN) +;;; BIND-REQUIREDS ((var1 . arg1-loc) ... (varN . argN-loc)) +;;; BIND-SPECIAL destination value-loc +;;; CALL-LOCAL destination fun (arg1 ... argN) +;;; CALL-GLOBAL destination fun (arg1 ... argN) +;;; C-INLINE +;;; DEBUG-ENV-OPEN fun-name +;;; DEBUG-ENV-PUSH-VARS (var1 ... varN) +;;; DEBUG-ENV-POP-VARS (var1 ... varN) close-block +;;; DEBUG-ENV-CLOSE fun-name +;;; DO-FLET/LABELS (fun1 ... funN) +;;; FRAME-ID frame-var +;;; FRAME-JMP-NEXT frame-var +;;; FRAME-POP frame-var +;;; FRAME-SAVE-NEXT frame-var +;;; FRAME-SET id-loc no-label +;;; FUNCALL destination (arg1 ... argN) +;;; FUNCTION-PROLOGUE fun +;;; FUNCTION-EPILOGUE fun +;;; GO tag +;;; JMP tag +;;; PROGV ndx-loc (var1-loc ... varN-loc) values-loc +;;; PROGV-EXIT ndx-loc +;;; SET destination source +;;; SET-MV (dest-loc1 ... dest-locN) min-args max-args +;;; SI:STRUCTURE-REF +;;; SI:STRUCTURE-SET +;;; STACK-FRAME-OPEN frame-var +;;; STACK-FRAME-PUSH frame-var value-loc +;;; STACK-FRAME-PUSH-VALUES frame-var +;;; STACK-FRAME-POP-VALUES frame-var +;;; STACK-FRAME-APPLY frame-var fun-loc +;;; STACK-FRAME-CLOSE frame-var +;;; RETURN-FROM block-id-var block-name +;;; THROW tag-loc +;;; UNBIND (var1 ... varN) +;;; VALUES (value1-loc ... valueN-loc) +;;; VARARGS-BIND nargs-loc varargs-loc min max nkeys check +;;; VARARGS-POP dest-loc nargs-loc varargs-loc +;;; VARARGS-REST dest-loc nargs-loc varargs-loc nkeys +;;; keys-list-loc allow-other-keys +;;; VARARGS-UNBIND nargs-loc varargs-loc min max nkeys check ;;; (in-package "C-PASSES") diff --git a/src/new-cmp/cmpprop.lsp b/src/new-cmp/cmpprop.lsp index 54ada0408..c71fe88f4 100644 --- a/src/new-cmp/cmpprop.lsp +++ b/src/new-cmp/cmpprop.lsp @@ -21,51 +21,51 @@ ;;; ;;; ALL C1FORMS: Intermediate language used by the compiler ;;; -;;; (LOCATION loc) -;;; (VAR var) -;;; (SETQ var value-c1form) -;;; (PSETQ var-list value-c1form-list) -;;; (BLOCK blk-var progn-c1form) -;;; (TAGBODY tag-var tag-body) -;;; (RETURN-FROM blk-var return-type value) -;;; (FUNCALL fun-value (arg-value*)) -;;; (CALL-LOCAL obj-fun (arg-value*)) -;;; (CALL-GLOBAL fun-name (arg-value*)) -;;; (CATCH catch-value body-c1form) -;;; (UNWIND-PROTECT protected-c1form body) -;;; (THROW catch-value output-value) -;;; (GO tag-var return-type) -;;; (C-INLINE (arg-c1form*) -;;; (arg-type-symbol*) -;;; output-rep-type -;;; c-expression-string -;;; side-effects-p -;;; one-liner-p) -;;; (DO-FLET/LABELS {FLET|LABELS} funob-list lambda-expr-list) -;;; (IF fmla-c1form true-c1form false-c1form) -;;; (FMLA-NOT fmla-c1form) -;;; (LAMBDA lambda-list doc body-c1form) -;;; (LET/LET* vars-list var-init-c1form-list progn-c1form) -;;; (VALUES values-c1form-list) -;;; (MULTIPLE-VALUE-SETQ vars-list values-c1form-list) -;;; (MULTIPLE-VALUE-BIND vars-list init-c1form body) -;;; (COMPILER-LET symbols values body) -;;; (FUNCTION {GLOBAL|CLOSURE} lambda-form fun-object) +;;; (LOCATION loc) +;;; (VAR var) +;;; (SETQ var value-c1form) +;;; (PSETQ var-list value-c1form-list) +;;; (BLOCK blk-var progn-c1form) +;;; (TAGBODY tag-var tag-body) +;;; (RETURN-FROM blk-var return-type value) +;;; (FUNCALL fun-value (arg-value*)) +;;; (CALL-LOCAL obj-fun (arg-value*)) +;;; (CALL-GLOBAL fun-name (arg-value*)) +;;; (CATCH catch-value body-c1form) +;;; (UNWIND-PROTECT protected-c1form body) +;;; (THROW catch-value output-value) +;;; (GO tag-var return-type) +;;; (C-INLINE (arg-c1form*) +;;; (arg-type-symbol*) +;;; output-rep-type +;;; c-expression-string +;;; side-effects-p +;;; one-liner-p) +;;; (DO-FLET/LABELS {FLET|LABELS} funob-list lambda-expr-list) +;;; (IF fmla-c1form true-c1form false-c1form) +;;; (FMLA-NOT fmla-c1form) +;;; (LAMBDA lambda-list doc body-c1form) +;;; (LET/LET* vars-list var-init-c1form-list progn-c1form) +;;; (VALUES values-c1form-list) +;;; (MULTIPLE-VALUE-SETQ vars-list values-c1form-list) +;;; (MULTIPLE-VALUE-BIND vars-list init-c1form body) +;;; (COMPILER-LET symbols values body) +;;; (FUNCTION {GLOBAL|CLOSURE} lambda-form fun-object) ;;; -;;; (SI:STRUCTURE-REF struct-c1form type-name slot-index {:UNSAFE|NIL}) -;;; (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form) +;;; (SI:STRUCTURE-REF struct-c1form type-name slot-index {:UNSAFE|NIL}) +;;; (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form) ;;; -;;; (WITH-STACK body) -;;; (STACK-PUSH-VALUES value-c1form push-statement-c1form) +;;; (WITH-STACK body) +;;; (STACK-PUSH-VALUES value-c1form push-statement-c1form) ;;; -;;; (LOAD-TIME-VALUE dest-loc value-c1form) -;;; (FSET function-object vv-loc, macro-p pprint-p lambda-form) +;;; (LOAD-TIME-VALUE dest-loc value-c1form) +;;; (FSET function-object vv-loc, macro-p pprint-p lambda-form) ;;; -;;; body = (c1form*) -;;; tag-body = ({c1form | tag}*) -;;; return-type = {CLB | CCB | UNWIND-PROTECT} -;;; *value = c1form -;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) +;;; body = (c1form*) +;;; tag-body = ({c1form | tag}*) +;;; return-type = {CLB | CCB | UNWIND-PROTECT} +;;; *value = c1form +;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) ;;; ;;; diff --git a/src/new-cmp/cmpspecial.lsp b/src/new-cmp/cmpspecial.lsp index fe2c73432..b3eeb3f4b 100644 --- a/src/new-cmp/cmpspecial.lsp +++ b/src/new-cmp/cmpspecial.lsp @@ -57,24 +57,24 @@ (check-args-number 'FUNCTION args 1 1) (let ((fun (car args))) (cond ((si::valid-function-name-p fun) - (let ((funob (local-function-ref fun t))) - (if funob + (let ((funob (local-function-ref fun t))) + (if funob (c1set-loc destination (fun-var funob)) (c1set-loc destination `(FDEFINITION ,fun))))) ((and (consp fun) (member (car fun) '(LAMBDA EXT::LAMBDA-BLOCK))) (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) - (let (name body) - (if (eq (first fun) 'EXT::LAMBDA) - (setf name (gensym) body (rest fun)) - (setf name (second fun) body (cddr fun))) - (let* ((funob (c1compile-function body :name name)) - (lambda-form (fun-lambda funob))) - (setf (fun-ref-ccb funob) t) - (compute-fun-closure-type funob) + (let (name body) + (if (eq (first fun) 'EXT::LAMBDA) + (setf name (gensym) body (rest fun)) + (setf name (second fun) body (cddr fun))) + (let* ((funob (c1compile-function body :name name)) + (lambda-form (fun-lambda funob))) + (setf (fun-ref-ccb funob) t) + (compute-fun-closure-type funob) (nconc (c1do-flet/labels-op (list funob)) (c1set-loc destination `(MAKE-CCLOSURE ,funob)))))) - (t (cmperr "The function ~s is illegal." fun))))) + (t (cmperr "The function ~s is illegal." fun))))) ;;; Mechanism for sharing code. (defun new-local (fun) @@ -89,7 +89,7 @@ ;; new variables created. This way, the same lexical environment ;; can be propagated through nested FLET/LABELS. (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) - (fun-env fun) 0))) + (fun-env fun) 0))) (otherwise (setf (fun-env fun) 0 (fun-level fun) 0))) (push fun *local-funs*)) diff --git a/src/new-cmp/cmpstack.lsp b/src/new-cmp/cmpstack.lsp index 2f0c47a0a..e72ec8cfe 100644 --- a/src/new-cmp/cmpstack.lsp +++ b/src/new-cmp/cmpstack.lsp @@ -13,11 +13,11 @@ ;;;; ;;;; Following special forms are provided: ;;;; -;;;; (WITH-STACK {form}*) -;;;; Executes given forms, restoring the lisp stack on output. -;;;; (STACK-PUSH form) -;;;; (STACK-PUSH-VALUES form) -;;;; (STACK-POP nvalues) +;;;; (WITH-STACK {form}*) +;;;; Executes given forms, restoring the lisp stack on output. +;;;; (STACK-PUSH form) +;;;; (STACK-PUSH-VALUES form) +;;;; (STACK-POP nvalues) ;;;; (in-package "COMPILER") diff --git a/src/new-cmp/cmpstructures.lsp b/src/new-cmp/cmpstructures.lsp index 8011c7b23..5f029c388 100644 --- a/src/new-cmp/cmpstructures.lsp +++ b/src/new-cmp/cmpstructures.lsp @@ -34,55 +34,55 @@ (defun maybe-optimize-structure-access (destination fname args) (let* ((slot-description (get-sysprop fname 'SYS::STRUCTURE-ACCESS))) (when (and slot-description - (inline-possible fname) - (policy-inline-slot-access-p)) + (inline-possible fname) + (policy-inline-slot-access-p)) ;(format t "~%;;; Optimizing structure accessor ~A" fname) (let (struture-type slot-index) - (unless (and (consp slot-description) - (setf structure-type (car slot-description) - slot-index (cdr slot-description)) - (typep slot-index 'fixnum)) - (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A" - fname slot-index) - (return-from maybe-optimize-structure-access nil)) - (unless (= (length args) 1) - (cmpwarn "Too many arguments for structure slot accessor ~A" fname) - (return-from maybe-optimize-structure-access nil)) - (setf args (first args)) - (cond - ((eq structure-type 'list) - (c1expr destination `(elt ,args ,slot-index))) - ((eq structure-type 'vector) - (c1expr destination `(svref ,args ,slot-index))) - ((consp structure-type) - (c1expr destination `(aref (the ,structure-type ,args) ,slot-index))) - (t + (unless (and (consp slot-description) + (setf structure-type (car slot-description) + slot-index (cdr slot-description)) + (typep slot-index 'fixnum)) + (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A" + fname slot-index) + (return-from maybe-optimize-structure-access nil)) + (unless (= (length args) 1) + (cmpwarn "Too many arguments for structure slot accessor ~A" fname) + (return-from maybe-optimize-structure-access nil)) + (setf args (first args)) + (cond + ((eq structure-type 'list) + (c1expr destination `(elt ,args ,slot-index))) + ((eq structure-type 'vector) + (c1expr destination `(svref ,args ,slot-index))) + ((consp structure-type) + (c1expr destination `(aref (the ,structure-type ,args) ,slot-index))) + (t (c1structure-ref destination `(,args ',structure-type ,slot-index)))))))) (defun c1structure-ref (destination args) (check-args-number 'sys:structure-ref args 3) ;(format t "~%;;; Optimizing structure-ref for ~A" args) (let* ((form (first args)) - (c-form (c1expr 'SHOULD-BE-TEMP form)) - (name (second args)) - (index (third args))) + (c-form (c1expr 'SHOULD-BE-TEMP form)) + (name (second args)) + (index (third args))) (if (and (constantp name) - (constantp index)) - (let* ((name (cmp-eval name)) - (index (cmp-eval index)) - (type (get-slot-type name index))) - (make-c1form* 'SYS:STRUCTURE-REF :type type - :args c-form (add-symbol name) index - (if (or (subtypep (c1form-primary-type c-form) structure-type) - (policy-assume-no-errors)) - :unsafe - nil))) - (c1call-global destination 'sys:structure-ref args)))) + (constantp index)) + (let* ((name (cmp-eval name)) + (index (cmp-eval index)) + (type (get-slot-type name index))) + (make-c1form* 'SYS:STRUCTURE-REF :type type + :args c-form (add-symbol name) index + (if (or (subtypep (c1form-primary-type c-form) structure-type) + (policy-assume-no-errors)) + :unsafe + nil))) + (c1call-global destination 'sys:structure-ref args)))) (defun c2structure-ref (form name-vv index unsafe) (let* ((*inline-blocks* 0) (*temp* *temp*) - (loc (first (coerce-locs (inline-args (list form)))))) + (loc (first (coerce-locs (inline-args (list form)))))) (unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index unsafe)) (close-inline-blocks))) @@ -96,32 +96,32 @@ (defun c1structure-set (destination args) (if (and (not (safe-compile)) ; Beppe - (not (endp args)) - (not (endp (cdr args))) - (consp (second args)) - (eq (caadr args) 'QUOTE) - (not (endp (cdadr args))) - (symbolp (cadadr args)) - (endp (cddadr args)) - (not (endp (cddr args))) - (sys::fixnump (third args)) - (not (endp (cdddr args))) - (endp (cddddr args))) + (not (endp args)) + (not (endp (cdr args))) + (consp (second args)) + (eq (caadr args) 'QUOTE) + (not (endp (cdadr args))) + (symbolp (cadadr args)) + (endp (cddadr args)) + (not (endp (cddr args))) + (sys::fixnump (third args)) + (not (endp (cdddr args))) + (endp (cddddr args))) (let ((x (c1expr 'SHOULD-BE-TEMP (car args))) - (y (c1expr 'SHOULD-BE-TEMP (fourth args))) - (name (cadadr args))) - (let* ((slot-type (get-slot-type name (third args)))) + (y (c1expr 'SHOULD-BE-TEMP (fourth args))) + (name (cadadr args))) + (let* ((slot-type (get-slot-type name (third args)))) (enforce-types 'SI:STRUCTURE-SET (list slot-type) (list y) (list (fourth args)))) - (make-c1form* 'SYS:STRUCTURE-SET + (make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y) - :args x (add-symbol name) (third args) y)) + :args x (add-symbol name) (third args) y)) (c1call-global destination 'SYS:STRUCTURE-SET args))) (defun c2structure-set (x name-vv index y - &aux locs (*inline-blocks* 0)) + &aux locs (*inline-blocks* 0)) ;; the third argument here *c1t* is just a hack to ensure that ;; a variable is introduced for y if it is an expression with side effects (let* ((*inline-blocks* 0) diff --git a/src/new-cmp/cmptag.lsp b/src/new-cmp/cmptag.lsp index 9ca2b6662..b64c4b9b5 100644 --- a/src/new-cmp/cmptag.lsp +++ b/src/new-cmp/cmptag.lsp @@ -34,37 +34,37 @@ ;; Find a maximal iteration interval in TAGBODY from first to end ;; then increment the var-ref slot. (labels ((add-reg1 (form) - ;; increase the var-ref in FORM for all vars - (cond ((c1form-p form) - (dolist (v (c1form-args form)) - (add-reg1 v))) - ((consp form) - (dolist (v form) - (add-reg1 v))) - ((var-p form) - (incf (var-ref form) (the fixnum *reg-amount*))))) - (jumps-to-p (clause tag-name) - ;; Does CLAUSE have a go TAG-NAME in it? - (cond ((c1form-p clause) - (and (eq (c1form-name clause) 'GO) - (eq (tag-name (c1form-arg 0 clause)) tag-name))) - ((atom clause) nil) - (t (or (jumps-to-p (car clause) tag-name) - (jumps-to-p (cdr clause) tag-name)))))) + ;; increase the var-ref in FORM for all vars + (cond ((c1form-p form) + (dolist (v (c1form-args form)) + (add-reg1 v))) + ((consp form) + (dolist (v form) + (add-reg1 v))) + ((var-p form) + (incf (var-ref form) (the fixnum *reg-amount*))))) + (jumps-to-p (clause tag-name) + ;; Does CLAUSE have a go TAG-NAME in it? + (cond ((c1form-p clause) + (and (eq (c1form-name clause) 'GO) + (eq (tag-name (c1form-arg 0 clause)) tag-name))) + ((atom clause) nil) + (t (or (jumps-to-p (car clause) tag-name) + (jumps-to-p (cdr clause) tag-name)))))) (do ((v tagbody (cdr v)) - (end nil) - (first nil)) - ((null v) - (do ((ww first (cdr ww))) - ((eq ww end) (add-reg1 (car ww))) - (add-reg1 (car ww)))) + (end nil) + (first nil)) + ((null v) + (do ((ww first (cdr ww))) + ((eq ww end) (add-reg1 (car ww))) + (add-reg1 (car ww)))) (when (tag-p (car v)) - (unless first (setq first v)) - (do ((w (cdr v) (cdr w)) - (name (tag-name (car v)))) - ((null w)) - (when (jumps-to-p (car w) name) - (setq end w))))))) + (unless first (setq first v)) + (do ((w (cdr v) (cdr w)) + (name (tag-name (car v)))) + ((null w)) + (when (jumps-to-p (car w) name) + (setq end w))))))) (defun make-tagbody-labels (body *cmp-env*) "Produces two values. The first one is a list of forms where atoms have been @@ -94,9 +94,9 @@ The second value is an association list of atoms to the tags they represent." *cmp-env*))) (defun c1tagbody (destination orig-body &aux (*cmp-env* *cmp-env*) - (tag-var (make-var :name (gensym "TAGBODY-ID") :kind NIL)) - (tag-index 0) - (body nil) + (tag-var (make-var :name (gensym "TAGBODY-ID") :kind NIL)) + (tag-index 0) + (body nil) (tags nil)) ;; Register variable and frame for cleanup forms (cmp-env-register-var tag-var *cmp-env*) @@ -120,12 +120,12 @@ The second value is an association list of atoms to the tags they represent." with output = '() with tag-body = nil do (cond ((tag-p form) - (when tag-body - (setf output (cons (nreverse tag-body) output) - tag-body nil)) - (push form output)) - (t - (push form tag-body))) + (when tag-body + (setf output (cons (nreverse tag-body) output) + tag-body nil)) + (push form output)) + (t + (push form tag-body))) finally (setf body (if tag-body (cons (nreverse tag-body) output) output))) @@ -168,9 +168,9 @@ The second value is an association list of atoms to the tags they represent." (unless (or (symbolp name) (integerp name)) (cmperr "The tag name ~s is not a symbol nor an integer." name)) (multiple-value-bind (tag ccb clb unw) - (cmp-env-search-tag name) + (cmp-env-search-tag name) (unless tag - (cmperr "Undefined tag ~A" name)) + (cmperr "Undefined tag ~A" name)) (let ((var (tag-var tag))) (cond (ccb (setf (tag-ref-ccb tag) t (var-ref-ccb var) T diff --git a/src/new-cmp/cmptop.lsp b/src/new-cmp/cmptop.lsp index a173e2c88..6b2323914 100644 --- a/src/new-cmp/cmptop.lsp +++ b/src/new-cmp/cmptop.lsp @@ -59,39 +59,39 @@ (let ((*current-toplevel-form* (list form *current-toplevel-form*)) (fun (car form)) (args (cdr form)) fd) - (when (member fun *toplevel-forms-to-print*) - (print-current-form)) - (cond + (when (member fun *toplevel-forms-to-print*) + (print-current-form)) + (cond ((consp fun) (t1ordinary destination form)) ((not (symbolp fun)) - (cmperr "~s is illegal function." fun)) - ((eq fun 'QUOTE) - (t1ordinary destination 'NIL)) - ((setq fd (get-sysprop fun 'T1)) - (funcall fd destination args)) - ((or (get-sysprop fun 'C1) (get-sysprop fun 'C1SPECIAL)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary destination 'NIL)) + ((setq fd (get-sysprop fun 'T1)) + (funcall fd destination args)) + ((or (get-sysprop fun 'C1) (get-sysprop fun 'C1SPECIAL)) (t1ordinary destination form)) - ((and (setq fd (compiler-macro-function fun)) - (inline-possible fun) - (let ((success nil)) - (multiple-value-setq (fd success) - (cmp-expand-macro fd form)) - success)) + ((and (setq fd (compiler-macro-function fun)) + (inline-possible fun) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd form)) + success)) (push 'macroexpand *current-toplevel-form*) - (t1expr* destination fd)) - ((setq fd (cmp-macro-function fun)) + (t1expr* destination fd)) + ((setq fd (cmp-macro-function fun)) (push 'macroexpand *current-toplevel-form*) - (t1expr* destination (cmp-expand-macro fd form))) - (t (t1ordinary destination form)) - ))))) + (t1expr* destination (cmp-expand-macro fd form))) + (t (t1ordinary destination form)) + ))))) (defun t1/c1expr (destination form) (cond ((not *compile-toplevel*) - (c1translate destination form)) - ((atom form) - (t1ordinary destination form)) - (t - (t1expr* destination form)))) + (c1translate destination form)) + ((atom form) + (t1ordinary destination form)) + (t + (t1expr* destination form)))) (defun c1progn (destination forms) (or (loop for fl on forms @@ -103,33 +103,33 @@ (if (null decls) (c1progn destination body) (let* ((*cmp-env* (add-declarations decls (cmp-env-copy *cmp-env*)))) - (c1progn destination body)))) + (c1progn destination body)))) (defun c1eval-when (destination args) (check-args-number 'EVAL-WHEN args 1) (let ((load-flag nil) - (compile-flag nil) - (execute-flag nil)) + (compile-flag nil) + (execute-flag nil)) (dolist (situation (car args)) (case situation - ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) - ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) - ((EVAL :EXECUTE) - (if *compile-toplevel* - (setq compile-flag (or *compile-time-too* compile-flag)) - (setq execute-flag t))) - (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." - situation)))) + ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) + ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((EVAL :EXECUTE) + (if *compile-toplevel* + (setq compile-flag (or *compile-time-too* compile-flag)) + (setq execute-flag t))) + (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." + situation)))) (cond ((not *compile-toplevel*) - (c1progn destination (and execute-flag (rest args)))) - (load-flag - (let ((*compile-time-too* compile-flag)) - (c1progn destination (rest args)))) - (compile-flag - (cmp-eval (cons 'PROGN (rest args))) - (c1progn destination 'NIL)) - (t - (c1progn destination 'NIL))))) + (c1progn destination (and execute-flag (rest args)))) + (load-flag + (let ((*compile-time-too* compile-flag)) + (c1progn destination (rest args)))) + (compile-flag + (cmp-eval (cons 'PROGN (rest args))) + (c1progn destination 'NIL)) + (t + (c1progn destination 'NIL))))) (defun t1ordinary (destination form) (when *compile-time-too* (cmp-eval form)) @@ -146,19 +146,19 @@ (defun c1load-time-value (destination args) (check-args-number 'LOAD-TIME-VALUE args 1 2) (let ((form (first args)) - loc) + loc) (cond ((not (listp *load-time-values*)) - ;; When using COMPILE, we set *load-time-values* to 'VALUES and - ;; thus signal that we do not want to compile these forms, but - ;; just to retain their value. - (return-from c1load-time-value (c1constant-value destination + ;; When using COMPILE, we set *load-time-values* to 'VALUES and + ;; thus signal that we do not want to compile these forms, but + ;; just to retain their value. + (return-from c1load-time-value (c1constant-value destination (cmp-eval form) :always t))) ((typep form '(or list symbol)) - (setf loc (data-empty-loc)) - (setf *load-time-values* (nconc *load-time-values* + (setf loc (data-empty-loc)) + (setf *load-time-values* (nconc *load-time-values* (c1translate loc form)))) - (t - (setf loc (add-object (cmp-eval form))))) + (t + (setf loc (add-object (cmp-eval form))))) (c1set-loc destination loc))) (defun c1locally (destination args) @@ -179,10 +179,10 @@ (check-args-number 'SYMBOL-MACROLET args 1) (let ((*cmp-env* (cmp-env-copy))) (dolist (def (car args)) - (let ((name (first def))) - (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) - "The symbol-macro definition ~s is illegal." def) - (cmp-env-register-symbol-macro name (second def)))) + (let ((name (first def))) + (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) + "The symbol-macro definition ~s is illegal." def) + (cmp-env-register-symbol-macro name (second def)))) (c1locally destination (cdr args)))) (defun t1defmacro (destination args) @@ -216,11 +216,11 @@ (= (length fun-form) 1) (setf fun-form (first fun-form)) (eq (c1form-name fun-form) 'FUNCTION) - (not (eq (c1form-arg 0 fun-form) 'GLOBAL))) - (let ((fun-object (c1form-arg 2 fun-form))) + (not (eq (c1form-arg 0 fun-form) 'GLOBAL))) + (let ((fun-object (c1form-arg 2 fun-form))) (setf (fun-child-funs *current-function*) (delete fun-object (fun-child-funs *current-function*))) - (cond ((fun-no-entry fun-object) + (cond ((fun-no-entry fun-object) (when macro (cmperr "Declaration C-LOCAL used in macro ~a" (fun-name fun))) (make-c1form* 'SI:FSET :args fun-object nil nil nil nil)) diff --git a/src/new-cmp/cmptranslate.lsp b/src/new-cmp/cmptranslate.lsp index 776ac5b33..d48cf6905 100644 --- a/src/new-cmp/cmptranslate.lsp +++ b/src/new-cmp/cmptranslate.lsp @@ -119,7 +119,7 @@ (push temp ,vars)) (push temp ,temps) forms))) - (,postfix (c1unbind (setf ,vars (nreverse ,vars))))) + (,postfix (c1unbind (setf ,vars (nreverse ,vars))))) (setf prefix (nconc (c1bind ,vars) prefix) ,temps (nreverse ,temps)) ,@body))) @@ -225,7 +225,7 @@ (defun c1set-from-values (new-destination) (maybe-add-to-set-nodes new-destination - (c1set-loc new-destination 'VALUES))) + (c1set-loc new-destination 'VALUES))) (defun c1set-mv (locations &optional (min-args 0) (max-args multiple-values-limit)) (maybe-add-to-set-nodes locations diff --git a/src/new-cmp/cmpvar.lsp b/src/new-cmp/cmpvar.lsp index 9b7814007..608e64c28 100644 --- a/src/new-cmp/cmpvar.lsp +++ b/src/new-cmp/cmpvar.lsp @@ -18,7 +18,7 @@ (let ((var (apply #'%make-var args))) (unless (member (var-kind var) '(SPECIAL GLOBAL)) (when *current-function* - (push var (fun-local-vars *current-function*)))) + (push var (fun-local-vars *current-function*)))) var)) ;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too @@ -26,7 +26,7 @@ ;;; variable are actually called from the given node. The problem arises when ;;; we create a closure of a function, as in ;;; -;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) +;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) ;;; ;;; To know whether A is changed or read, we would have to track where B is ;;; actually used. @@ -139,18 +139,18 @@ (cmpck (constantp name) "The constant ~s is being bound." name) (let (type) (if (setq type (assoc name types)) - (setq type (cdr type)) - (setq type 'T)) + (setq type (cdr type)) + (setq type 'T)) (cond ((or (member name specials) - (sys:specialp name) - (check-global name)) ;; added. Beppe 17 Aug 1987 + (sys:specialp name) + (check-global name)) ;; added. Beppe 17 Aug 1987 (unless type - (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) - (c1make-global-variable name :kind 'SPECIAL :type type)) + (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) + (c1make-global-variable name :kind 'SPECIAL :type type)) (t - (make-var :name name :type type :loc 'OBJECT - :kind 'LEXICAL ; we rely on check-vref to fix it - :ref (if (member name ignores) -1 0)))))) + (make-var :name name :type type :loc 'OBJECT + :kind 'LEXICAL ; we rely on check-vref to fix it + :ref (if (member name ignores) -1 0)))))) (defun c1var (destination name) (let ((vref (c1vref name (eq destination 'TRASH)))) @@ -174,10 +174,10 @@ (unless (and maybe-drop-ref (not (policy-global-var-checking))) (c1make-global-variable name :warn t :type (or (get-sysprop name 'CMP-TYPE) t)))) - ((not (var-p var)) - ;; symbol-macrolet - (baboon)) - (t + ((not (var-p var)) + ;; symbol-macrolet + (baboon)) + (t (when (and maybe-drop-ref (not (and (global-var-p var) (policy-global-var-checking)))) @@ -185,14 +185,14 @@ (when (minusp (var-ref var)) ; IGNORE. (cmpwarn-style "The ignored variable ~s is used." name) (setf (var-ref var) 0)) - (when (eq (var-kind var) 'LEXICAL) - (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB - (var-ref-ccb var) t - (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT)) - (clb (setf (var-ref-clb var) t - (var-loc var) 'OBJECT)))) - var)))) + (when (eq (var-kind var) 'LEXICAL) + (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (clb (setf (var-ref-clb var) t + (var-loc var) 'OBJECT)))) + var)))) (defun global-var-p (var) (and (var-p var) @@ -217,8 +217,8 @@ (push var *global-var-objects*) (when warn (unless (or (sys:specialp name) (constantp name) (check-global name)) - (undefined-variable name) - (push var *undefined-vars*))) + (undefined-variable name) + (push var *undefined-vars*))) var)) (defun c1declare-specials (globals) @@ -227,8 +227,8 @@ (defun si::register-global (name) (unless (check-global name) (push (c1make-global-variable name :kind 'GLOBAL - :type (or (get-sysprop name 'CMP-TYPE) 'T)) - *global-vars*)) + :type (or (get-sysprop name 'CMP-TYPE) 'T)) + *global-vars*)) (values)) (defun c1setq (destination args) @@ -236,8 +236,8 @@ (declare (fixnum l)) (cmpck (oddp l) "SETQ requires an even number of arguments.") (cond ((zerop l) (c1nil destination)) - ((= l 2) (c1setq1 destination (first args) (second args))) - (t + ((= l 2) (c1setq1 destination (first args) (second args))) + (t (c1progn destination (loop while args collect `(SETQ ,(pop args) ,(pop args)))))))) @@ -251,9 +251,9 @@ (c1with-saved-one-value (prefix postfix temp form) (let* ((name1 (c1vref name))) (nconc prefix - (c1set-loc name1 temp) - postfix - (unless (eq destination 'trash) (c1set-loc destination name1)))))) + (c1set-loc name1 temp) + postfix + (unless (eq destination 'trash) (c1set-loc destination name1)))))) (defun unused-variable-p (var) "Is the value of the variable ever read?" @@ -265,18 +265,18 @@ (check-args-number 'PROGV args 2) (c1with-temps (ndx-prefix ndx-postfix bds-ndx) (let* ((variables (pop args)) - (values (pop args))) + (values (pop args))) (c1with-saved-values (prefix postfix temps (list variables values)) - (let* ((cleanup (c1progv-exit-op bds-ndx)) - (*cmp-env* (cmp-env-register-cleanup cleanup - (cmp-env-copy *cmp-env*)))) - (nconc ndx-prefix - prefix - (c1progv-op bds-ndx (first temps) (second temps)) - (c1progn destination args) + (let* ((cleanup (c1progv-exit-op bds-ndx)) + (*cmp-env* (cmp-env-register-cleanup cleanup + (cmp-env-copy *cmp-env*)))) + (nconc ndx-prefix + prefix + (c1progv-op bds-ndx (first temps) (second temps)) + (c1progn destination args) (c1progv-exit-op bds-ndx) - postfix - ndx-postfix)))))) + postfix + ndx-postfix)))))) (defun c1psetq (destination args) (let* ((variables '()) diff --git a/src/new-cmp/defsys.lsp.in b/src/new-cmp/defsys.lsp.in index 1f95d30b9..200c16891 100644 --- a/src/new-cmp/defsys.lsp.in +++ b/src/new-cmp/defsys.lsp.in @@ -1,41 +1,41 @@ ;;; ---------------------------------------------------------------------- -;;; CLOS +;;; CLOS ;;; ---------------------------------------------------------------------- (defparameter *cmp-modules* - ;; file load compile files which force - ;; environment environment recompilations of - ;; this file + ;; file load compile files which force + ;; environment environment recompilations of + ;; this file '( - (cmpdefs () () ()) - (cmpmac () () ()) - (cmpinline () () ()) - (cmputil () () ()) - (cmptype () () ()) - (cmpbind () () ()) - (cmpblock () () ()) - (cmpcall () () ()) - (cmpcatch () () ()) - (cmpenv () () ()) - (cmpeval () () ()) - (cmpexit () () ()) - (cmpflet () () ()) - (cmpfun () () ()) - (cmpif () () ()) - (cmplam () () ()) - (cmplet () () ()) - (cmploc () () ()) - (cmpmap () () ()) - (cmpmulti () () ()) - (cmpspecial () () ()) - (cmptag () () ()) - (cmptop () () ()) - (cmpvar () () ()) - (cmpwt () () ()) - (cmpmain () () ()) - (cmpffi () () ()) - (cmpcfg () () ()))) + (cmpdefs () () ()) + (cmpmac () () ()) + (cmpinline () () ()) + (cmputil () () ()) + (cmptype () () ()) + (cmpbind () () ()) + (cmpblock () () ()) + (cmpcall () () ()) + (cmpcatch () () ()) + (cmpenv () () ()) + (cmpeval () () ()) + (cmpexit () () ()) + (cmpflet () () ()) + (cmpfun () () ()) + (cmpif () () ()) + (cmplam () () ()) + (cmplet () () ()) + (cmploc () () ()) + (cmpmap () () ()) + (cmpmulti () () ()) + (cmpspecial () () ()) + (cmptag () () ()) + (cmptop () () ()) + (cmpvar () () ()) + (cmpwt () () ()) + (cmpmain () () ()) + (cmpffi () () ()) + (cmpcfg () () ()))) (sbt:defsystem cmp diff --git a/src/tests/bugs/cl-001.lsp b/src/tests/bugs/cl-001.lsp index 5a3c5bb41..a26a9e6ca 100755 --- a/src/tests/bugs/cl-001.lsp +++ b/src/tests/bugs/cl-001.lsp @@ -10,10 +10,10 @@ ;;; Fixed: 20/05/2006 (Brian Spilsbury) ;;; Description: ;;; -;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) -;;; fails to import symbol NIL because IMPORT is invoked as -;;; (IMPORT NIL (find-package "CL")), which does not import -;;; any symbol. +;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) +;;; fails to import symbol NIL because IMPORT is invoked as +;;; (IMPORT NIL (find-package "CL")), which does not import +;;; any symbol. ;;; (deftest cl-0001-import @@ -28,8 +28,8 @@ ;;; Fixed: 20/05/2006 (Brian Spilsbury) ;;; Description: ;;; -;;; Compiled FLET forms failed to shadow global macro definitions, if not -;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1] +;;; Compiled FLET forms failed to shadow global macro definitions, if not +;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1] ;;; (deftest cl-0002-macro-shadow @@ -37,13 +37,13 @@ (with-compiler ("aux-cl-0002.lsp") '(defmacro foo () 2) '(defmacro test (symbol &environment env) - (and (macro-function symbol env) t)) + (and (macro-function symbol env) t)) '(defun doit () (flet ((foo () 1)) (test foo)))) (load "aux-cl-0002") (delete-file "aux-cl-0002.lsp") (delete-file (compile-file-pathname "aux-cl-0002" :type :fas)) (prog1 - (doit) + (doit) (fmakunbound 'doit) (fmakunbound 'test) (fmakunbound 'foo))) @@ -53,12 +53,12 @@ ;;; Fixed: 14/06/2006 (juanjo) ;;; Description: ;;; -;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. +;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. ;;; (deftest cl-0003-apropos (and (equal (apropos-list "bin") - (apropos-list "bin")) + (apropos-list "bin")) t) t) @@ -66,8 +66,8 @@ ;;; Fixed: 02/08/2006 (juanjo) ;;; Description: ;;; -;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on -;;; Gray streams. +;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on +;;; Gray streams. ;;; (deftest cl-0004-streamp @@ -77,7 +77,7 @@ ;;; Date: 02/08/2006 (juanjo) ;;; Description: ;;; -;;; There is a problem with SUBTYPEP and type STREAM +;;; There is a problem with SUBTYPEP and type STREAM ;;; (deftest cl-0005-subtypep-stream @@ -88,14 +88,14 @@ ;;; Fixed: 09/07/2006 (Tim S) ;;; Description: ;;; -;;; ENOUGH-NAMESTRING provided too large pathnames even when the -;;; pathname was a subdirectory of the default pathname. +;;; ENOUGH-NAMESTRING provided too large pathnames even when the +;;; pathname was a subdirectory of the default pathname. ;;; ;;; Date: 31/12/2006 (Richard M. Kreuter) ;;; Fixed: 5/1/2007 (Juanjo) ;;; Description: -;;; ENOUGH-NAMESTRING does not simplify the pathname when the -;;; directory matches completely that of the default path. +;;; ENOUGH-NAMESTRING does not simplify the pathname when the +;;; directory matches completely that of the default path. ;;; (defvar *enough-namestring_tests* @@ -118,31 +118,31 @@ ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*" "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" "")) ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot" - "/A/c/d.sot" "../c/d.sot" + "/A/c/d.sot" "../c/d.sot" "c/e/d.sot")))) (deftest cl-0006-enough-namestring (labels ((test-path (path defaults) - (let* ((e-ns (enough-namestring path defaults)) - (d1 (pathname-directory path)) - (d2 (pathname-directory defaults)) - (d3 (pathname-directory e-ns))) - (and (equalp (merge-pathnames e-ns defaults) - (merge-pathnames (parse-namestring path nil defaults) - defaults)) - ;; If directories concide, the "enough-namestring" - ;; removes the directory. But only if the pathname is - ;; absolute. - (not (and (equal (first d1) ':absolute) - (equalp d1 d2) - d3))))) - (test-default+paths (default+paths) - (let ((defaults (first default+paths)) - (paths (second default+paths))) - (every (lambda (path) - (handler-case (test-path path defaults) - (error (error) 'NIL))) - paths)))) + (let* ((e-ns (enough-namestring path defaults)) + (d1 (pathname-directory path)) + (d2 (pathname-directory defaults)) + (d3 (pathname-directory e-ns))) + (and (equalp (merge-pathnames e-ns defaults) + (merge-pathnames (parse-namestring path nil defaults) + defaults)) + ;; If directories concide, the "enough-namestring" + ;; removes the directory. But only if the pathname is + ;; absolute. + (not (and (equal (first d1) ':absolute) + (equalp d1 d2) + d3))))) + (test-default+paths (default+paths) + (let ((defaults (first default+paths)) + (paths (second default+paths))) + (every (lambda (path) + (handler-case (test-path path defaults) + (error (error) 'NIL))) + paths)))) (every #'test-default+paths *enough-namestring_tests*)) t) @@ -150,47 +150,47 @@ ;;; Fixed: 1/09/2006 (juanjo) ;;; Details: ;;; -;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is -;;; not NIL and the adjustable array does not have a fill pointer +;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is +;;; not NIL and the adjustable array does not have a fill pointer ;;; (deftest cl-0007-adjustable-array (loop for fp in '(nil t) collect - (loop for i in '(t nil 0 1 2 3) collect - (and - (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4 - :fill-pointer i) - (type-error (c) nil) - (error (c) t)) - t))) + (loop for i in '(t nil 0 1 2 3) collect + (and + (handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4 + :fill-pointer i) + (type-error (c) nil) + (error (c) t)) + t))) ((nil t nil nil nil nil) (t t t t t t))) ;;; Date: 09/10/2006 (Dustin Long) ;;; Fixed: 10/10/2006 ;;; Description: ;;; -;;; The namestring "." is improperly parsed, getting a file type of "" -;;; Additionally we found it more convenient to have the _last_ dot mark -;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt" +;;; The namestring "." is improperly parsed, getting a file type of "" +;;; Additionally we found it more convenient to have the _last_ dot mark +;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt" ;;; (deftest cl-0008-parse-namestring (loop for (namestring name type) in - '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt") - ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt")) - unless (let ((x (parse-namestring namestring))) - (and (equal name (pathname-name x)) - (equal type (pathname-type x)) - (equal '() (pathname-directory x)))) - collect namestring) + '(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt") + ("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt")) + unless (let ((x (parse-namestring namestring))) + (and (equal name (pathname-name x)) + (equal type (pathname-type x)) + (equal '() (pathname-directory x)))) + collect namestring) ()) ;;; Date: 28/09/2006 ;;; Fixed: 10/10/2006 ;;; Description: ;;; -;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized -;;; The following code tests that at least three objects are finalized. +;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized +;;; The following code tests that at least three objects are finalized. ;;; ;;; Note: this test fails in multithreaded mode. GC takes too long! #-ecl @@ -198,16 +198,16 @@ (let ((*all-tags* '())) (declare (special *all-tags*)) (flet ((custom-finalizer (tag) - #'(lambda (o) (push tag *all-tags*)))) - (let ((a '())) - (dotimes (i 5) - (let ((x (cons i i))) - (si::set-finalizer x (custom-finalizer i)) - (push x a)))) - (dotimes (j 100) - (dotimes (i 10000) - (cons 1.0 1.0)) - (si::gc t))) + #'(lambda (o) (push tag *all-tags*)))) + (let ((a '())) + (dotimes (i 5) + (let ((x (cons i i))) + (si::set-finalizer x (custom-finalizer i)) + (push x a)))) + (dotimes (j 100) + (dotimes (i 10000) + (cons 1.0 1.0)) + (si::gc t))) (sort *all-tags* #'<)) (0 1 2 3 4)) @@ -216,24 +216,24 @@ ;;; Fixed: 10/10/2006 (Dustin Long) ;;; Description: ;;; -;;; Hash table iterators have to check that their argument is -;;; really a hash table. +;;; Hash table iterators have to check that their argument is +;;; really a hash table. ;;; (deftest cl-0010-hash-iterator (loop for i in *mini-universe* - when (and (not (hash-table-p i)) - (handler-case (progn (loop for k being the hash-keys of i) t) - (error (c) nil))) - collect (type-of i)) + when (and (not (hash-table-p i)) + (handler-case (progn (loop for k being the hash-keys of i) t) + (error (c) nil))) + collect (type-of i)) nil) ;;; Date: 31/12/2006 (Richard M. Kreuter) ;;; Fixed: 5/1/2007 (Juanjo) ;;; Description: ;;; -;;; The keyword :BACK does not work as expected when creating pathnames -;;; and causes an error when at the beginning: (:RELATIVE :BACK) +;;; The keyword :BACK does not work as expected when creating pathnames +;;; and causes an error when at the beginning: (:RELATIVE :BACK) ;;; (deftest cl-0011-make-pathname-with-back @@ -242,66 +242,66 @@ with x = (if (zerop l) 0 (random (1+ l))) with y = (if (= l x) 0 (random (- l x))) nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i))) - (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil))) - (d1 (list* :absolute (subseq l2 0 x))) - (d2 (list* :relative (subseq l2 x nil))) - (d3 (list* :absolute l2)) - (d4 (list* :relative l2)) - (p1 (handler-case (make-pathname :directory d1) - (error (c) nil))) - (p2 (handler-case (make-pathname :directory d2) - (error (c) nil))) - (p3 (handler-case (make-pathname :directory d3) - (error (c) nil))) - (p4 (handler-case (make-pathname :directory d4) - (error (c) nil)))) - (if (and p1 p2 p3 p4 + (l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil))) + (d1 (list* :absolute (subseq l2 0 x))) + (d2 (list* :relative (subseq l2 x nil))) + (d3 (list* :absolute l2)) + (d4 (list* :relative l2)) + (p1 (handler-case (make-pathname :directory d1) + (error (c) nil))) + (p2 (handler-case (make-pathname :directory d2) + (error (c) nil))) + (p3 (handler-case (make-pathname :directory d3) + (error (c) nil))) + (p4 (handler-case (make-pathname :directory d4) + (error (c) nil)))) + (if (and p1 p2 p3 p4 ;; MERGE-PATHNAMES eliminates :BACK - (equalp l (rest (pathname-directory (merge-pathnames p2 p1)))) + (equalp l (rest (pathname-directory (merge-pathnames p2 p1)))) ;; MAKE-PATHNAME does not eliminate :BACK - (not (equalp l (rest (pathname-directory (make-pathname :directory d3))))) - (not (equalp l (rest (pathname-directory (make-pathname :directory d4)))))) - nil - (list (list l d1 d2 d3 d4 l2 x y))))) + (not (equalp l (rest (pathname-directory (make-pathname :directory d3))))) + (not (equalp l (rest (pathname-directory (make-pathname :directory d4)))))) + nil + (list (list l d1 d2 d3 d4 l2 x y))))) nil) ;;; Date: 11/03/2007 (Fare) ;;; Fixed: 23/03/2007 (Juanjo) ;;; Description: ;;; -;;; COPY-READTABLE did not copy the entries of the "from" table -;;; when a second argument, i.e. a "destination" table was supplied. +;;; COPY-READTABLE did not copy the entries of the "from" table +;;; when a second argument, i.e. a "destination" table was supplied. ;;; (deftest cl-0012-copy-readtable (let ((from-readtable (copy-readtable)) - (to-readtable (copy-readtable)) - (char-list '())) + (to-readtable (copy-readtable)) + (char-list '())) (dotimes (i 20) - (let* ((code (+ 32 (random 70))) - (c (code-char code))) - (push c char-list) - (set-macro-character c - (eval `(lambda (str ch) ,code)) - nil - from-readtable))) + (let* ((code (+ 32 (random 70))) + (c (code-char code))) + (push c char-list) + (set-macro-character c + (eval `(lambda (str ch) ,code)) + nil + from-readtable))) (copy-readtable from-readtable to-readtable) (loop for c in char-list - unless (and (eql (char-code c) - (let ((*readtable* from-readtable)) - (read-from-string (string c)))) - (eq (get-macro-character c from-readtable) - (get-macro-character c to-readtable))) - collect c)) + unless (and (eql (char-code c) + (let ((*readtable* from-readtable)) + (read-from-string (string c)))) + (eq (get-macro-character c from-readtable) + (get-macro-character c to-readtable))) + collect c)) nil) ;;; Date: 05/01/2008 (Anonymous, SF bug report) ;;; Fixed: 06/01/2008 (Juanjo) ;;; Description: ;;; -;;; For a file linked as follows "ln -s //usr/ /tmp/foo", -;;; (truename #p"/tmp/foo") signals an error because //usr is -;;; parsed as a hostname. +;;; For a file linked as follows "ln -s //usr/ /tmp/foo", +;;; (truename #p"/tmp/foo") signals an error because //usr is +;;; parsed as a hostname. ;;; #-windows @@ -316,54 +316,54 @@ ;;; Fixed: 01/09/2008 (Juanjo) ;;; Description: ;;; -;;; Inside the form read by #., recursive definitions a la #n= -;;; and #n# were not properly expanded +;;; Inside the form read by #., recursive definitions a la #n= +;;; and #n# were not properly expanded ;;; (deftest cl-0014-sharp-dot (with-output-to-string (*standard-output*) (let ((*print-circle* t)) - (read-from-string "'#.(princ (list '#1=(1 2) '#1#))"))) + (read-from-string "'#.(princ (list '#1=(1 2) '#1#))"))) "(#1=(1 2) #1#)") ;;; Date: 30/08/2008 (Josh Elsasser) ;;; Fixed: 30/08/2008 (Josh Elsasser) ;;; Description: ;;; -;;; A setf expansion that produces a form with a macro that also has -;;; its own setf expansion does not giver rise to the right code. +;;; A setf expansion that produces a form with a macro that also has +;;; its own setf expansion does not giver rise to the right code. ;;; (deftest cl-0015-setf-expander (progn (define-setf-expander triple (place &environment env) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place env) - (let ((store (gensym))) - (values dummies - vals - `(,store) - `(let ((,(car newval) (/ ,store 3))) - (triple ,setter)) - `(progn - (triple ,getter)))))) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((store (gensym))) + (values dummies + vals + `(,store) + `(let ((,(car newval) (/ ,store 3))) + (triple ,setter)) + `(progn + (triple ,getter)))))) (defmacro hidden (val) - `(triple ,val)) + `(triple ,val)) (defmacro triple (val) - `(* 3 ,val)) + `(* 3 ,val)) (prog1 - (equalp (eval '(let ((foo 5)) - (list foo (triple foo) (setf (triple foo) 6) foo (triple foo)))) - (eval '(let ((foo 5)) - (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo))))) - (fmakunbound 'hidden) - (fmakunbound 'triple))) + (equalp (eval '(let ((foo 5)) + (list foo (triple foo) (setf (triple foo) 6) foo (triple foo)))) + (eval '(let ((foo 5)) + (list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo))))) + (fmakunbound 'hidden) + (fmakunbound 'triple))) T) ;;; Date: 17/2/2009 ;;; Fixed: 17/2/2009 ;;; Description: ;;; -;;; The defstruct form fails with an :include field that overwrites -;;; a slot that is read only. +;;; The defstruct form fails with an :include field that overwrites +;;; a slot that is read only. ;;; (deftest cl-0016-defstruct-include (progn @@ -385,7 +385,7 @@ ;;; Fixed: 9/11/2009 ;;; Description: ;;; -;;; LOAD does not work with special files (/dev/null) +;;; LOAD does not work with special files (/dev/null) ;;; (deftest cl-0017-load-special (handler-case (and (load #+(or windows mingw32) "NULL" @@ -398,7 +398,7 @@ ;;; Fixed: 20/11/2009 (Juanjo) ;;; Description: ;;; -;;; #= and ## reader macros do not work well with #. +;;; #= and ## reader macros do not work well with #. ;;; (deftest cl-0018-sharp-eq (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))")) @@ -409,15 +409,15 @@ ;;; Fixed: 20/11/2009 (Juanjo) ;;; Description: ;;; -;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL. +;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL. ;;; (deftest cl-0019-fdefinition (and (handler-case (fdefinition nil) - (undefined-function (c) t) - (serious-condition (c) nil)) + (undefined-function (c) t) + (serious-condition (c) nil)) (handler-case (symbol-function nil) - (undefined-function (c) t) - (serious-condition (c) nil))) + (undefined-function (c) t) + (serious-condition (c) nil))) t) @@ -425,7 +425,7 @@ ;;; Fixed: 29/11/2009 (Juanjo) ;;; Description: ;;; -;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. +;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. ;;; (deftest cl-0020-make-instances-obsolete (progn @@ -452,8 +452,8 @@ ;;; Fixed: 4/12/2009 (Juanjo) ;;; Description: ;;; -;;; Conversion of rationals into floats is done by truncating, not by -;;; rounding, what implies a loss of accuracy. +;;; Conversion of rationals into floats is done by truncating, not by +;;; rounding, what implies a loss of accuracy. ;;; (deftest cl-0021-ratio-to-float ;; The test builds a ratio which is very close to 1 but which is below it @@ -477,7 +477,7 @@ ;;; Fixed: 4/12/2009 ;;; Description: ;;; -;;; Inspection of structs is broken due to undefined inspect-indent +;;; Inspection of structs is broken due to undefined inspect-indent ;;; (deftest cl-0022-inspect-struct (let ((*query-io* (make-string-input-stream "q diff --git a/src/tests/bugs/cmp-001.lsp b/src/tests/bugs/cmp-001.lsp index 03c477165..cc685aba0 100644 --- a/src/tests/bugs/cmp-001.lsp +++ b/src/tests/bugs/cmp-001.lsp @@ -10,52 +10,52 @@ ;;; Fixed: 14/04/2006 (juanjo) ;;; Description: ;;; -;;; The inner RETURN form should return to the outer block. +;;; The inner RETURN form should return to the outer block. ;;; However, the closure (lambda (x) ...) is improperly translated -;;; by the compiler to (lambda (x) (block nil ...) and thus this -;;; form outputs '(1 2 3 4). +;;; by the compiler to (lambda (x) (block nil ...) and thus this +;;; form outputs '(1 2 3 4). ;;; (deftest cmp-0001-block (funcall (compile nil - '(lambda () - (block nil - (funcall 'mapcar - #'(lambda (x) - (when x (return x))) - '(1 2 3 4)))) - )) + '(lambda () + (block nil + (funcall 'mapcar + #'(lambda (x) + (when x (return x))) + '(1 2 3 4)))) + )) 1) ;;; Fixed: 12/01/2006 (juanjo) ;;; Description: ;;; -;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as -;;; synonyms. +;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as +;;; synonyms. ;;; ;;; (deftest cmp-0002-pathname (and (equalp (compile-file-pathname "foo" :type :fas) - (compile-file-pathname "foo" :type :fasl)) - t) + (compile-file-pathname "foo" :type :fasl)) + t) t) ;;; Fixed: 21/12/2005 (juanjo) ;;; Description: ;;; -;;; Compute the path of the intermediate files (*.c, *.h, etc) -;;; relative to that of the fasl or object file. +;;; Compute the path of the intermediate files (*.c, *.h, etc) +;;; relative to that of the fasl or object file. ;;; (deftest cmp-0003-paths (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) - (h-file (compile-file-pathname output :type :h)) - (c-file (compile-file-pathname output :type :c)) - (data-file (compile-file-pathname output :type :data))) + (h-file (compile-file-pathname output :type :h)) + (c-file (compile-file-pathname output :type :c)) + (data-file (compile-file-pathname output :type :data))) (and (zerop (si::system "rm -rf tmp; mkdir tmp")) (with-compiler ("aux-cmp-0003-paths.lsp" :output-file output :c-file t - :h-file t :data-file t) - '(defun foo (x) (1+ x))) + :h-file t :data-file t) + '(defun foo (x) (1+ x))) (probe-file output) (probe-file c-file) (probe-file h-file) @@ -69,18 +69,18 @@ ;;; Fixed: 09/03/2006 (juanjo) ;;; Description: ;;; -;;; DEFCONSTANT does not declare the symbol as global and thus the -;;; compiler issues warnings when the symbol is referenced in the -;;; same file in which it is defined as constant. +;;; DEFCONSTANT does not declare the symbol as global and thus the +;;; compiler issues warnings when the symbol is referenced in the +;;; same file in which it is defined as constant. ;;; #-ecl-bytecmp (deftest cmp-0004-defconstant-warn (let ((warn nil)) (with-dflet ((c::cmpwarn (setf warn t))) - (with-compiler ("aux-cmp-0004.lsp") - '(defconstant foo (list 1 2 3)) - '(print foo))) + (with-compiler ("aux-cmp-0004.lsp") + '(defconstant foo (list 1 2 3)) + '(print foo))) (delete-file "aux-cmp-0004.lsp") (delete-file (compile-file-pathname "aux-cmp-0004.lsp" :type :fas)) warn) @@ -91,23 +91,23 @@ ;;; Fixed: 16/04/2006 (juanjo) ;;; Description: ;;; -;;; Special declarations should only affect the variable bound and -;;; not their initialization forms. That, even if the variables are -;;; the arguments of a function. +;;; Special declarations should only affect the variable bound and +;;; not their initialization forms. That, even if the variables are +;;; the arguments of a function. ;;; (deftest cmp-0005-declaration (let ((form '(lambda (y) - (flet ((faa (&key (x y)) - (declare (special y)) - x)) - (let ((y 4)) - (declare (special y)) - (faa)))))) + (flet ((faa (&key (x y)) + (declare (special y)) + x)) + (let ((y 4)) + (declare (special y)) + (faa)))))) ;; We must test that both the intepreted and the compiled form ;; output the same value. (list (funcall (compile 'nil form) 3) - (funcall (coerce form 'function) 3))) + (funcall (coerce form 'function) 3))) (3 3)) ;;; Date: 26/04/2006 @@ -115,44 +115,44 @@ ;;; Fixed: ---- ;;; Description: ;;; -;;; Functions with more than 64 arguments have to be invoked using -;;; the lisp stack. +;;; Functions with more than 64 arguments have to be invoked using +;;; the lisp stack. ;;; (deftest cmp-0006-call-arguments-limit (let ((form '(lambda () - (list (list - 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0 - 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0 - 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0 - 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1 - 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1 - 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1 - 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2 - 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2 - 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2 - 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3 - 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3 - 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3 - 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4 - 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4 - 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4 - 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5 - 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5 - 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5 - 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6 - 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6 - 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6))))) + (list (list + 'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0 + 'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0 + 'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0 + 'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1 + 'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1 + 'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1 + 'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2 + 'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2 + 'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2 + 'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3 + 'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3 + 'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3 + 'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4 + 'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4 + 'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4 + 'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5 + 'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5 + 'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5 + 'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6 + 'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6 + 'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6))))) (equal (funcall (compile 'foo form)) - (funcall (coerce form 'function)))) + (funcall (coerce form 'function)))) t) ;;; Date: 16/05/2005 ;;; Fixed: 18/05/2006 (juanjo) ;;; Description: ;;; -;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM -;;; breaks down with some circular structures +;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM +;;; breaks down with some circular structures ;;; (defclass cmp-007-class () @@ -170,11 +170,11 @@ (deftest cmp-0007-circular-load-form (loop for object in - (let ((l (list 1 2 3))) - (list l - (subst 3 l l) - (make-instance 'cmp-007-class) - (subst (make-instance 'cmp-007-class) 3 l))) + (let ((l (list 1 2 3))) + (list l + (subst 3 l l) + (make-instance 'cmp-007-class) + (subst (make-instance 'cmp-007-class) 3 l))) collect (clos::need-to-make-load-form-p object nil)) (nil nil t t)) @@ -182,14 +182,14 @@ ;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo) ;;; Description: ;;; -;;; The compiler is not able to externalize constants that have no printed representation. -;;; In that case MAKE-LOAD-FORM should be used. +;;; The compiler is not able to externalize constants that have no printed representation. +;;; In that case MAKE-LOAD-FORM should be used. ;;; (deftest cmp-0008-make-load-form (let ((output (compile-file-pathname "aux-cmp-0008.lsp" :type :fasl))) (with-open-file (s "aux-cmp-0008.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output) - (princ " + (princ " (eval-when (:compile-toplevel) (defvar s4 (make-instance 'cmp-007-class)) (defvar s5 (make-instance 'cmp-007-class)) @@ -206,38 +206,38 @@ (compile-file "aux-cmp-0008.lsp") (load output) (prog1 (foo) - (delete-file output) - (delete-file "aux-cmp-0008.lsp"))) + (delete-file output) + (delete-file "aux-cmp-0008.lsp"))) "#1=(1 2 3 # #1#)") ;;; Date: 9/06/2006 (Pascal Costanza) ;;; Fixed: 13/06/2006 (juanjo) ;;; Description: ;;; -;;; A MACROLET function creates a set of local macro definitions. -;;; The forms that expand these macros are themselves affected by -;;; enclosing MACROLET and SYMBOL-MACRO definitions: -;;; (defun bar () -;;; (macrolet ((x () 2)) -;;; (macrolet ((m () (x))) -;;; (m)))) -;;; (compile 'bar) -;;; (bar) => 2 +;;; A MACROLET function creates a set of local macro definitions. +;;; The forms that expand these macros are themselves affected by +;;; enclosing MACROLET and SYMBOL-MACRO definitions: +;;; (defun bar () +;;; (macrolet ((x () 2)) +;;; (macrolet ((m () (x))) +;;; (m)))) +;;; (compile 'bar) +;;; (bar) => 2 ;;; (deftest cmp-0009-macrolet (list (progn (defun bar () - (macrolet ((x () 2)) - (macrolet ((m () (x))) - (m)))) + (macrolet ((x () 2)) + (macrolet ((m () (x))) + (m)))) (compile 'bar) (bar)) (progn (defun bar () - (symbol-macrolet ((x 2)) - (macrolet ((m () x)) - (m)))) + (symbol-macrolet ((x 2)) + (macrolet ((m () x)) + (m)))) (compile 'bar) (bar))) (2 2)) @@ -245,112 +245,112 @@ ;;; Fixed: 13/06/2006 (juanjo) ;;; Description: ;;; -;;; A MACROLET that references a local variable from the form in -;;; which it appears can cause corruption in the interpreter. We -;;; solve this by signalling errors whenever such reference -;;; happens. +;;; A MACROLET that references a local variable from the form in +;;; which it appears can cause corruption in the interpreter. We +;;; solve this by signalling errors whenever such reference +;;; happens. ;;; -;;; Additionally MACROLET forms should not see the other macro -;;; definitions on the same form, much like FLET functions cannot -;;; call their siblings. +;;; Additionally MACROLET forms should not see the other macro +;;; definitions on the same form, much like FLET functions cannot +;;; call their siblings. ;;; (deftest cmp-0010-macrolet (flet ((eval-with-error (form) - (handler-case (eval form) - (error (c) 'error)))) + (handler-case (eval form) + (error (c) 'error)))) (makunbound 'cmp-0010-foo) (fmakunbound 'cmp-0010-foo) (let ((faa 1)) (declare (special faa)) (mapcar #'eval-with-error - '((let ((faa 2)) - (macrolet ((m () faa)) - (m))) - (let ((faa 4)) - (declare (special faa)) - (macrolet ((m () faa)) - (m))) - (let ((faa 4)) - (declare (special cmp-0010-foo)) - (macrolet ((m () cmp-0010-foo)) - (m))) - (let ((faa 5)) - (macrolet ((m () cmp-0010-foo)) - (m))) - (macrolet ((cmp-0010-foo () 6)) - (macrolet ((m () (cmp-0010-foo))) - (m))) - (macrolet ((f1 () 7) - (f2 () 8)) - ;; M should not see the new definitions F1 and F2 - (macrolet ((f1 () 9) - (f2 () 10) - (m () (list 'quote (list (f1) (f2))))) - (m))) - (flet ((cmp-0010-foo () 1)) - (macrolet ((m () (cmp-0010-foo))) - (m))) - (labels ((cmp-0010-foo () 1)) - (macrolet ((m () (cmp-0010-foo))) - (m))))))) + '((let ((faa 2)) + (macrolet ((m () faa)) + (m))) + (let ((faa 4)) + (declare (special faa)) + (macrolet ((m () faa)) + (m))) + (let ((faa 4)) + (declare (special cmp-0010-foo)) + (macrolet ((m () cmp-0010-foo)) + (m))) + (let ((faa 5)) + (macrolet ((m () cmp-0010-foo)) + (m))) + (macrolet ((cmp-0010-foo () 6)) + (macrolet ((m () (cmp-0010-foo))) + (m))) + (macrolet ((f1 () 7) + (f2 () 8)) + ;; M should not see the new definitions F1 and F2 + (macrolet ((f1 () 9) + (f2 () 10) + (m () (list 'quote (list (f1) (f2))))) + (m))) + (flet ((cmp-0010-foo () 1)) + (macrolet ((m () (cmp-0010-foo))) + (m))) + (labels ((cmp-0010-foo () 1)) + (macrolet ((m () (cmp-0010-foo))) + (m))))))) (error 1 error error 6 (7 8) error error )) ;;; Date: 22/06/2006 (juanjo) ;;; Fixed: 29/06/2006 (juanjo) ;;; Description: ;;; -;;; ECL only accepted functions with less than 65 required -;;; arguments. Otherwise it refused to compile the function. The fix must -;;; respect the limit in the number of arguments passed in the C stack and -;;; use the lisp stack for the other required arguments. +;;; ECL only accepted functions with less than 65 required +;;; arguments. Otherwise it refused to compile the function. The fix must +;;; respect the limit in the number of arguments passed in the C stack and +;;; use the lisp stack for the other required arguments. ;;; #-ecl-bytecmp (deftest cmp-0011-c-arguments-limit (mapcar #'(lambda (nargs) - (let* ((arg-list (loop for i from 0 below nargs - collect (intern (format nil "arg~d" i)))) - (data (loop for i from 0 below nargs collect i)) - (lambda-form `(lambda ,arg-list - (and (equalp (list ,@arg-list) ',data) - ,nargs))) - (c:*compile-verbose* nil) - (c:*compile-print* nil) - (function (compile 'foo lambda-form))) - (list (apply function (subseq data 0 nargs)) - (handler-case (apply function (make-list (1+ nargs))) - (error (c) :error)) - (handler-case (apply function (make-list (1- nargs))) - (error (c) :error))))) - '(10 20 30 40 50 63 64 65 70)) + (let* ((arg-list (loop for i from 0 below nargs + collect (intern (format nil "arg~d" i)))) + (data (loop for i from 0 below nargs collect i)) + (lambda-form `(lambda ,arg-list + (and (equalp (list ,@arg-list) ',data) + ,nargs))) + (c:*compile-verbose* nil) + (c:*compile-print* nil) + (function (compile 'foo lambda-form))) + (list (apply function (subseq data 0 nargs)) + (handler-case (apply function (make-list (1+ nargs))) + (error (c) :error)) + (handler-case (apply function (make-list (1- nargs))) + (error (c) :error))))) + '(10 20 30 40 50 63 64 65 70)) ((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR) (40 :ERROR :ERROR) (50 :ERROR :ERROR) (63 :ERROR :ERROR) (64 :ERROR :ERROR) (65 :ERROR :ERROR) (70 :ERROR :ERROR))) (let* ((nargs 10) (arg-list (loop for i from 0 below nargs - collect (intern (format nil "arg~d" i)))) + collect (intern (format nil "arg~d" i)))) (arguments (make-list nargs))) (apply (compile 'foo `(lambda ,arg-list - (length (list ,@arg-list)))) - arguments)) + (length (list ,@arg-list)))) + arguments)) ;;; Date: 12/07/2008 (Josh Elsasser) ;;; Fixed: 02/08/2008 (Juanjo) ;;; Description: ;;; -;;; ECL fails to properly compute the closure type of a function that -;;; returns a lambda that calls the function itself. +;;; ECL fails to properly compute the closure type of a function that +;;; returns a lambda that calls the function itself. ;;; (deftest cmp-0012-compute-closure (and (with-compiler ("aux-cmp-0003-paths.lsp" :load t) - (defun testfun (outer) - (labels ((testlabel (inner) - (if inner - (testfun-map - (lambda (x) (testlabel x)) - inner)) - (print outer))) - (testlabel outer)))) + (defun testfun (outer) + (labels ((testlabel (inner) + (if inner + (testfun-map + (lambda (x) (testlabel x)) + inner)) + (print outer))) + (testlabel outer)))) t) t) @@ -358,38 +358,38 @@ ;;; Fixed: 12/09/2008 (Josh Elsasser) ;;; Description: ;;; -;;; FTYPE proclamations and declarations do not accept user defined -;;; function types. +;;; FTYPE proclamations and declarations do not accept user defined +;;; function types. ;;; (deftest cmp-0013-ftype-user-type (progn (deftype cmp-0013-float-function () '(function (float) float)) (deftype cmp-0013-float () 'float) (loop for (type . fails) in - '(((function (float) float) . nil) - (cons . t) - (cmp-0013-float-function . nil) - (cmp-0013-float . t)) - always (let ((form1 `(proclaim '(ftype ,type foo))) - (form2 `(compile nil '(lambda () - (declare (ftype ,type foo)) - (foo))))) - (if fails - (and (signals-error (eval form1) error) - (signals-error (eval form2) error) - t) - (progn - (eval form1) - (eval form2) - t))))) + '(((function (float) float) . nil) + (cons . t) + (cmp-0013-float-function . nil) + (cmp-0013-float . t)) + always (let ((form1 `(proclaim '(ftype ,type foo))) + (form2 `(compile nil '(lambda () + (declare (ftype ,type foo)) + (foo))))) + (if fails + (and (signals-error (eval form1) error) + (signals-error (eval form2) error) + t) + (progn + (eval form1) + (eval form2) + t))))) t) ;;; Date: 01/11/2008 (E. Marsden) ;;; Fixed: 02/11/2008 (Juanjo) ;;; Description: ;;; -;;; When compiled COERCE with type INTEGER may cause double -;;; evaluation of a form. +;;; When compiled COERCE with type INTEGER may cause double +;;; evaluation of a form. (deftest cmp-0014-coerce (funcall (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer))) @@ -400,7 +400,7 @@ ;;; Fixed: 08/11/2008 (Juanjo) ;;; Description: ;;; -;;; TYPEP, with a real type, produces strange results. +;;; TYPEP, with a real type, produces strange results. ;;; (deftest cmp-0015-coerce (funcall @@ -412,9 +412,9 @@ ;;; Fixed: 20/07/2008 (Juanjo) ;;; Description: ;;; -;;; In the new compiler, when compiling LET forms with special variables -;;; the values of the variables are not saved to make the assignments -;;; really parallel. +;;; In the new compiler, when compiling LET forms with special variables +;;; the values of the variables are not saved to make the assignments +;;; really parallel. ;;; (deftest cmp-0016-let-with-specials (progn @@ -448,7 +448,7 @@ ;;; Date: 06/10/2009 (J. Pellegrini) ;;; Fixed: 06/10/2009 (Juanjo) ;;; Description: -;;; Extended strings were not accepted as documentation by the interpreter. +;;; Extended strings were not accepted as documentation by the interpreter. ;;; (deftest cmp-0017-docstrings (handler-case @@ -461,7 +461,7 @@ ;;; Date: 07/11/2009 (A. Hefner) ;;; Fixed: 07/11/2009 (A. Hefner + Juanjo) ;;; Description: -;;; ECL ignores the IGNORABLE declaration +;;; ECL ignores the IGNORABLE declaration ;;; (deftest cmp-0018-ignorable (let ((c::*suppress-compiler-messages* t)) @@ -486,22 +486,22 @@ ;;; Date: 29/11/2009 (P. Costanza) ;;; Fixed: 29/11/2009 (Juanjo) ;;; Description: -;;; When calling a bytecodes (SETF ...) function from a compiled function -;;; an invalid memory access is produced. This is actually a consequence -;;; of a mismatch between the position of the fields bytecodes.entry -;;; and cfun.entry +;;; When calling a bytecodes (SETF ...) function from a compiled function +;;; an invalid memory access is produced. This is actually a consequence +;;; of a mismatch between the position of the fields bytecodes.entry +;;; and cfun.entry ;;; (deftest cmp-0019-bytecodes-entry-position (let ((indices (funcall (compile nil '(lambda () (ffi:c-inline () () list " - union cl_lispunion x[0]; - cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x; - cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x; - cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x; - cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x; - cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x; - @(return) = cl_list(5, MAKE_FIXNUM(bytecodes), + union cl_lispunion x[0]; + cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x; + cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x; + cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x; + cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x; + cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x; + @(return) = cl_list(5, MAKE_FIXNUM(bytecodes), MAKE_FIXNUM(bclosure), MAKE_FIXNUM(cfun), MAKE_FIXNUM(cfunfixed), @@ -512,8 +512,8 @@ ;;; Date: 07/02/2010 (W. Hebich) ;;; Fixed: 07/02/2010 (Juanjo) ;;; Description: -;;; THE forms do not understand VALUES types -;;; (the (values t) (funcall sym)) +;;; THE forms do not understand VALUES types +;;; (the (values t) (funcall sym)) ;;; (deftest cmp-0020-the-and-values (handler-case (and (compile 'foo '(lambda () (the (values t) (faa)))) diff --git a/src/tests/bugs/eformat-001.lsp b/src/tests/bugs/eformat-001.lsp index 601e59562..91a7b4787 100644 --- a/src/tests/bugs/eformat-001.lsp +++ b/src/tests/bugs/eformat-001.lsp @@ -37,23 +37,23 @@ name and the cdr is the corresponding external format. This list contains all possible variants w.r.t. to line-end conversion and endianness." (let ((variants (ecase symbol - (:ascii '(:us-ascii)) - (:latin1 '(:latin-1)) - (:latin8 '(:iso-8859-8)) - (:cp1252 '(:windows-cp1252)) - (:koi8r '(:koi8-r)) - (:utf8 '(:utf-8)) - (:ucs2 '(:ucs-2be :ucs-2le)) - (:ucs4 '(:ucs-4be :ucs-4le))))) + (:ascii '(:us-ascii)) + (:latin1 '(:latin-1)) + (:latin8 '(:iso-8859-8)) + (:cp1252 '(:windows-cp1252)) + (:koi8r '(:koi8-r)) + (:utf8 '(:utf-8)) + (:ucs2 '(:ucs-2be :ucs-2le)) + (:ucs4 '(:ucs-4be :ucs-4le))))) (loop for arg in variants nconc (let* ((endian-suffix (case arg - ((:ucs-2be :ucs-4be) "_be") - ((:ucs-2le :ucs-4le) "_le") - (t "")))) - (loop for eol-style in '(:lf :cr :crlf) - collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt" - file-name symbol eol-style endian-suffix) - (list eol-style arg))))))) + ((:ucs-2be :ucs-4be) "_be") + ((:ucs-2le :ucs-4le) "_le") + (t "")))) + (loop for eol-style in '(:lf :cr :crlf) + collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt" + file-name symbol eol-style endian-suffix) + (list eol-style arg))))))) (defun create-test-combinations (file-name symbols &optional simplep) "For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting @@ -76,14 +76,14 @@ contents \(viewed as binary files)." (with-open-file (stream1 file1 :element-type '(unsigned-byte 8)) (with-open-file (stream2 file2 :element-type '(unsigned-byte 8)) (if (= (file-length stream1) (file-length stream2)) - (loop for p1 = (file-position stream1) - for byte1 = (read-byte stream1 nil nil) - for byte2 = (read-byte stream2 nil nil) - while (and byte1 byte2) - unless (= byte1 byte2) - do (return (values nil p1)) - finally (return (values t 0))) - (values nil -1))))) + (loop for p1 = (file-position stream1) + for byte1 = (read-byte stream1 nil nil) + for byte2 = (read-byte stream2 nil nil) + while (and byte1 byte2) + unless (= byte1 byte2) + do (return (values nil p1)) + finally (return (values t 0))) + (values nil -1))))) (defun copy-stream (in out) "Copies the contents of the binary stream STREAM-IN to the @@ -115,45 +115,45 @@ Returns a true value iff all tests succeeded. Prints information about each individual comparison if VERBOSE is true." (labels ((copy-file (path-in external-format-in path-out external-format-out - direction-out direction-in) - (with-open-file (in path-in - :element-type 'character - :direction direction-in - :if-does-not-exist :error - :if-exists :overwrite - :external-format external-format-in) - (with-open-file (out path-out - :element-type 'character - :direction direction-out - :if-does-not-exist :create - :if-exists :supersede - :external-format external-format-out) - (funcall *copy-function* in out)))) + direction-out direction-in) + (with-open-file (in path-in + :element-type 'character + :direction direction-in + :if-does-not-exist :error + :if-exists :overwrite + :external-format external-format-in) + (with-open-file (out path-out + :element-type 'character + :direction direction-out + :if-does-not-exist :create + :if-exists :supersede + :external-format external-format-out) + (funcall *copy-function* in out)))) (one-comparison (path-in external-format-in path-out external-format-out) - (format t "~%;;; ~A -> ~A" path-in path-out) - (loop with full-path-in = (merge-pathnames path-in "./eformat-tests/") - and full-path-out = (ensure-directories-exist - (merge-pathnames path-out "./eformat-tmp/")) - and full-path-orig = (merge-pathnames path-out "./eformat-tests/") - for direction-out in '(:output :io) - nconc (loop for direction-in in '(:input :io) - for args = (list path-in external-format-in direction-in - path-out external-format-out direction-out) - with ok = nil - with pos = 0 - unless (progn - (copy-file full-path-in external-format-in - full-path-out external-format-out - direction-out direction-in) - (multiple-value-setq (ok pos) - (file-equal full-path-out full-path-orig))) - collect (progn - (format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%" - pos full-path-out full-path-orig) - args))))) + (format t "~%;;; ~A -> ~A" path-in path-out) + (loop with full-path-in = (merge-pathnames path-in "./eformat-tests/") + and full-path-out = (ensure-directories-exist + (merge-pathnames path-out "./eformat-tmp/")) + and full-path-orig = (merge-pathnames path-out "./eformat-tests/") + for direction-out in '(:output :io) + nconc (loop for direction-in in '(:input :io) + for args = (list path-in external-format-in direction-in + path-out external-format-out direction-out) + with ok = nil + with pos = 0 + unless (progn + (copy-file full-path-in external-format-in + full-path-out external-format-out + direction-out direction-in) + (multiple-value-setq (ok pos) + (file-equal full-path-out full-path-orig))) + collect (progn + (format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%" + pos full-path-out full-path-orig) + args))))) (loop with do-eformat-test-001-args-list = - (loop for (file-name symbols) in *eformat-test-files* - nconc (create-test-combinations file-name symbols)) + (loop for (file-name symbols) in *eformat-test-files* + nconc (create-test-combinations file-name symbols)) for (path-in external-format-in path-out external-format-out) in do-eformat-test-001-args-list nconc (one-comparison path-in external-format-in path-out external-format-out)))) @@ -162,9 +162,9 @@ about each individual comparison if VERBOSE is true." ;;; Fixed: Not a bug ;;; Description: ;;; -;;; Test external formats by transcoding several files into all possible -;;; supported formats and checking against the expected results. This -;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. +;;; Test external formats by transcoding several files into all possible +;;; supported formats and checking against the expected results. This +;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. ;;; (deftest eformat-0001-transcode-read-char (do-eformat-test-001 'copy-stream) @@ -175,9 +175,9 @@ about each individual comparison if VERBOSE is true." ;;; Fixed: Not a bug ;;; Description: ;;; -;;; Test external formats by transcoding several files into all possible -;;; supported formats and checking against the expected results. This -;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. +;;; Test external formats by transcoding several files into all possible +;;; supported formats and checking against the expected results. This +;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. ;;; (deftest eformat-0002-transcode-read-char (do-eformat-test-001 'copy-stream*) diff --git a/src/tests/bugs/eformat-002.lsp b/src/tests/bugs/eformat-002.lsp index f5dcae27a..387a2b23c 100644 --- a/src/tests/bugs/eformat-002.lsp +++ b/src/tests/bugs/eformat-002.lsp @@ -25,91 +25,91 @@ for c = (and byte (code-char byte)) while (and byte (or (null limit) (< i limit))) do (progn (when (zerop (mod i 8)) (terpri)) - (format t "~5X ~3A" byte - (cond ((and (< 31 byte 127) (standard-char-p c)) - c) - ((eql c #\Esc) "ESC") - (t " "))) - ))) + (format t "~5X ~3A" byte + (cond ((and (< 31 byte 127) (standard-char-p c)) + c) + ((eql c #\Esc) "ESC") + (t " "))) + ))) (terpri) (force-output)) (defun random-strings (char-bag n) (if (consp char-bag) (apply #'concatenate 'string - (loop for i from 0 below 2 - for actual-bag = (elt char-bag (random (length char-bag))) - collect (random-strings actual-bag (random n)))) + (loop for i from 0 below 2 + for actual-bag = (elt char-bag (random (length char-bag))) + collect (random-strings actual-bag (random n)))) (concatenate 'string - (loop for i from 0 to n - for c = (char char-bag (random (length char-bag))) - unless (eql c #\Newline) - collect c)))) + (loop for i from 0 to n + for c = (char char-bag (random (length char-bag))) + unless (eql c #\Newline) + collect c)))) (defun compare-files (a b &optional all-chars) (with-open-file (sa a :direction :input :element-type '(unsigned-byte 8)) (with-open-file (sb b :direction :input :element-type '(unsigned-byte 8)) (loop for b1 = (read-byte sa nil nil) - for b2 = (read-byte sb nil nil) - while (or b1 b2) - do (unless (eql b1 b2) - (let* ((position (1- (file-position sa))) - (start-dump (max 0 (- position 8)))) - (setf position (logandc2 position 3)) - (binary-dump a start-dump 32) - (binary-dump b start-dump 32) - (format t "~%Mismatch between~%~T~A~% and~T~A~% at file position ~D~%" - a b position) - (when all-chars - (loop with imin = (floor start-dump 4) - with imax = (min (+ imin 9) (length all-chars)) - for i from imin below imax - for j from 0 - for c = (char all-chars i) - do (progn (when (zerop (mod j 8)) (terpri)) - (format t "~4X " (char-code c)))) - (terpri)) - (return nil))) - finally (return t))))) + for b2 = (read-byte sb nil nil) + while (or b1 b2) + do (unless (eql b1 b2) + (let* ((position (1- (file-position sa))) + (start-dump (max 0 (- position 8)))) + (setf position (logandc2 position 3)) + (binary-dump a start-dump 32) + (binary-dump b start-dump 32) + (format t "~%Mismatch between~%~T~A~% and~T~A~% at file position ~D~%" + a b position) + (when all-chars + (loop with imin = (floor start-dump 4) + with imax = (min (+ imin 9) (length all-chars)) + for i from imin below imax + for j from 0 + for c = (char all-chars i) + do (progn (when (zerop (mod j 8)) (terpri)) + (format t "~4X " (char-code c)))) + (terpri)) + (return nil))) + finally (return t))))) (defun test-output (format-name &optional iconv-name (nlines 128) (nchars 10)) (set 'ext::foo format-name) (let* ((*print-circle* t) - (mappings (loop for table = (ext::make-encoding format-name) - while (and table (symbolp table)) - do (setf format-name table) - finally (return (or table format-name)))) - (char-bags (all-valid-unicode-chars mappings)) - (encoded-filename (format nil "eformat-tmp/iconv-~A.txt" format-name)) - (decoded-filename (format nil "eformat-tmp/iconv-~A-utf32.txt" format-name)) - (iconv-filename (format nil "eformat-tmp/iconv-~A-iconv-utf32.txt" format-name)) - (random-lines (loop for line from 1 to nlines - collect (random-strings char-bags nchars))) - (all-chars (apply #'concatenate 'string - (loop for i in random-lines - nconc (list i (list #\Newline)))))) + (mappings (loop for table = (ext::make-encoding format-name) + while (and table (symbolp table)) + do (setf format-name table) + finally (return (or table format-name)))) + (char-bags (all-valid-unicode-chars mappings)) + (encoded-filename (format nil "eformat-tmp/iconv-~A.txt" format-name)) + (decoded-filename (format nil "eformat-tmp/iconv-~A-utf32.txt" format-name)) + (iconv-filename (format nil "eformat-tmp/iconv-~A-iconv-utf32.txt" format-name)) + (random-lines (loop for line from 1 to nlines + collect (random-strings char-bags nchars))) + (all-chars (apply #'concatenate 'string + (loop for i in random-lines + nconc (list i (list #\Newline)))))) (ensure-directories-exist encoded-filename) ;; Output in that format (with-open-file (out encoded-filename :direction :output :external-format format-name - :if-exists :supersede) + :if-exists :supersede) (loop for i in random-lines - do (write-line i out))) + do (write-line i out))) (with-open-file (out decoded-filename :direction :output :external-format :ucs-4be - :if-exists :supersede) + :if-exists :supersede) (loop for i in random-lines - do (write-line i out))) + do (write-line i out))) (with-open-file (in encoded-filename :direction :input :external-format format-name) (loop for line = (read-line in nil nil) - for i in random-lines - for n from 1 - while line - unless (string= i line) - do (progn - (format t "Mismatch on line ~D between~% ~S and~% ~S" n line i) - (return-from test-output nil)))) + for i in random-lines + for n from 1 + while line + unless (string= i line) + do (progn + (format t "Mismatch on line ~D between~% ~S and~% ~S" n line i) + (return-from test-output nil)))) (when iconv-name (si::system (format nil "iconv -f ~A -t UTF-32BE ~A > ~A" - iconv-name encoded-filename iconv-filename)) + iconv-name encoded-filename iconv-filename)) (compare-files decoded-filename iconv-filename all-chars)))) ;;; Date: 09/01/2007 @@ -117,35 +117,35 @@ ;;; Fixed: Not a bug ;;; Description: ;;; -;;; Test external formats by transcoding random sequences of characters using -;;; ECL and iconv. +;;; Test external formats by transcoding random sequences of characters using +;;; ECL and iconv. ;;; (deftest eformat-0002-simple-iconv-check (loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4 - :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 - :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 - :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 + :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 + :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 + :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 - :KOI8-R :KOI8-U + :KOI8-R :KOI8-U - :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 - :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 - :IBM869 + :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 + :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 + :IBM869 - :CP936 :CP949 :CP950 + :CP936 :CP949 :CP950 - :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 - :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 + :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 + :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 - ; :CP932 :WINDOWS-1255 :WINDOWS-1258 with - ; iconv may output combined characters, when ECL would - ; output the base and the comibining one. Hence, no simple - ; comparison is possible. + ; :CP932 :WINDOWS-1255 :WINDOWS-1258 with + ; iconv may output combined characters, when ECL would + ; output the base and the comibining one. Hence, no simple + ; comparison is possible. - :ISO-2022-JP :ISO-2022-JP-1) + :ISO-2022-JP :ISO-2022-JP-1) unless (progn - (format t "~%;;; Testing ~A " name) - (loop for i from 1 to 10 - always (test-output name (symbol-name name)))) + (format t "~%;;; Testing ~A " name) + (loop for i from 1 to 10 + always (test-output name (symbol-name name)))) collect name) nil) diff --git a/src/tests/bugs/emb-001.lsp b/src/tests/bugs/emb-001.lsp index 5c7515cd1..033bf8ae0 100644 --- a/src/tests/bugs/emb-001.lsp +++ b/src/tests/bugs/emb-001.lsp @@ -7,7 +7,7 @@ (defun test-C-program (c-code &key capture-output) (with-open-file (s "tmp/aux.c" :direction :output :if-exists :supersede - :if-does-not-exist :create) + :if-does-not-exist :create) (princ c-code s)) (c::compiler-cc "tmp/aux.c" "tmp/aux.o") (c::linker-cc "tmp/aux.exe" "tmp/aux.o") @@ -17,15 +17,15 @@ (STRING (with-output-to-string (s) (let ((in (si::run-program "tmp/aux.exe" '() :output :stream)) - line) - (loop - (setf line (read-line in nil)) - (unless line (return)) - (write-line line s))))) + line) + (loop + (setf line (read-line in nil)) + (unless line (return)) + (write-line line s))))) (T (do* ((all '()) - (x t) - (in (si::run-program "tmp/aux.exe" '() :output :stream))) + (x t) + (in (si::run-program "tmp/aux.exe" '() :output :stream))) ((null in) all) (setf x (read in nil nil)) (unless x (return all)) @@ -35,9 +35,9 @@ ;;; Fixed: 23/06/2006 (juanjo) ;;; Description: ;;; -;;; Multiple invocations of cl_shutdown() can hang ECL. Also, -;;; cl_shutdown() is still invoked at exit (registered with -;;; atexit()) even if cl_shutdown was previously invoked. +;;; Multiple invocations of cl_shutdown() can hang ECL. Also, +;;; cl_shutdown() is still invoked at exit (registered with +;;; atexit()) even if cl_shutdown was previously invoked. ;;; ;;; Fixed: 03/2006 (juanjo) ;;; @@ -51,9 +51,9 @@ int main (int argc, char **argv) { cl_shutdown(); exit(0); }") - (form '(push (lambda () (print :shutdown)) ext::*exit-hooks*)) - (c-code (format nil skeleton (format nil "~S" form))) - (data (test-C-program (print c-code) :capture-output t))) + (form '(push (lambda () (print :shutdown)) ext::*exit-hooks*)) + (c-code (format nil skeleton (format nil "~S" form))) + (data (test-C-program (print c-code) :capture-output t))) data) '(:shutdown)) diff --git a/src/tests/bugs/ffi-001.lsp b/src/tests/bugs/ffi-001.lsp index fded46f61..bac356a54 100644 --- a/src/tests/bugs/ffi-001.lsp +++ b/src/tests/bugs/ffi-001.lsp @@ -10,31 +10,31 @@ ;;; Fixed: 26/02/2006 (juanjo) ;;; Description: ;;; -;;; Callback functions have to be declared static so that there -;;; are no conflicts among callbacks in different files. +;;; Callback functions have to be declared static so that there +;;; are no conflicts among callbacks in different files. ;;; ;;; Fixed: 13/04/2006 (juanjo) ;;; Description: ;;; -;;; Header should be included as +;;; Header should be included as ;;; (deftest ffi-001-callback (and (zerop (si::system "rm -rf tmp; mkdir tmp")) (with-open-file (s "tmp/a.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(ffi:defcallback foo :void () nil) s)) + :if-exists :supersede + :if-does-not-exist :create) + (print '(ffi:defcallback foo :void () nil) s)) (with-open-file (s "tmp/b.lsp" :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(ffi:defcallback foo :void () nil) s)) + :if-exists :supersede + :if-does-not-exist :create) + (print '(ffi:defcallback foo :void () nil) s)) (compile-file "tmp/a.lsp" :system-p t) (compile-file "tmp/b.lsp" :system-p t) (c:build-program "tmp/foo" :lisp-files - (list (compile-file-pathname "tmp/a.lsp" :type :object) - (compile-file-pathname "tmp/b.lsp" :type :object))) + (list (compile-file-pathname "tmp/a.lsp" :type :object) + (compile-file-pathname "tmp/b.lsp" :type :object))) (probe-file (compile-file-pathname "tmp/foo" :type :program)) (zerop (si::system "rm -rf tmp")) t) @@ -43,7 +43,7 @@ ;;; Date: 29/07/2008 ;;; From: Juajo ;;; Description: -;;; Callback examples based on the C compiler +;;; Callback examples based on the C compiler ;;; (deftest ffi-002-callback (and @@ -71,8 +71,8 @@ int (*foo)(int) = #0; ;;; Date: 29/07/2008 ;;; From: Juajo ;;; Description: -;;; Callback examples based on the DFFI. Only work if this feature -;;; has been linked in. +;;; Callback examples based on the DFFI. Only work if this feature +;;; has been linked in. ;;; #+(or) (deftest ffi-002b-callback diff --git a/src/tests/bugs/int-001.lsp b/src/tests/bugs/int-001.lsp index fbda5573e..4d4340d82 100644 --- a/src/tests/bugs/int-001.lsp +++ b/src/tests/bugs/int-001.lsp @@ -7,8 +7,8 @@ ;;; Description: ;;; -;;; The interpreter selectively complains when assigning a variable -;;; that has not been declared as special and is not local. +;;; The interpreter selectively complains when assigning a variable +;;; that has not been declared as special and is not local. ;;; ;;; Fixed: 03/2006 (juanjo) ;;; @@ -16,8 +16,8 @@ (mapcar (lambda (ext:*action-on-undefined-variable*) (handler-case - (progn (eval `(setq ,(gensym) 1)) :no-error) - (error (c) :error))) + (progn (eval `(setq ,(gensym) 1)) :no-error) + (error (c) :error))) '(nil ERROR)) (:no-error :error)) diff --git a/src/tests/bugs/mailbox-001.lsp b/src/tests/bugs/mailbox-001.lsp index e18ab346f..41837b48a 100644 --- a/src/tests/bugs/mailbox-001.lsp +++ b/src/tests/bugs/mailbox-001.lsp @@ -6,68 +6,68 @@ (in-package :cl-test) ;;; Date: 14/04/2012 -;;; Ensure that at creation name and counter are set, and mailbox is empty. +;;; Ensure that at creation name and counter are set, and mailbox is empty. (deftest mailbox-make-and-counter (loop with name = "mbox-make-and-counter" for count from 4 to 63 for mbox = (mp:make-mailbox :name name :count count) always (and (eq (mp:mailbox-name mbox) name) - (>= (mp:mailbox-count mbox) count) - (mp:mailbox-empty-p mbox) - t)) + (>= (mp:mailbox-count mbox) count) + (mp:mailbox-empty-p mbox) + t)) t) ;;; Date: 14/04/2012 -;;; Ensure that the mailbox works in a nonblocking fashion (when the -;;; number of messages < mailbox size in a single producer and single -;;; consumer setting. We do not need to create new threads for this. +;;; Ensure that the mailbox works in a nonblocking fashion (when the +;;; number of messages < mailbox size in a single producer and single +;;; consumer setting. We do not need to create new threads for this. (deftest mbox-mailbox-nonblocking-io-1-to-1 (loop with count = 30 with name = "mbox-mailbox-nonblocking-io-1-to-1" with mbox = (mp:make-mailbox :name name :count count) for l from 1 to 10 for messages = (loop for i from 1 to l - do (mp:mailbox-send mbox i) - collect i) + do (mp:mailbox-send mbox i) + collect i) always - (and (not (mp:mailbox-empty-p mbox)) - (equalp (loop for i from 1 to l - collect (mp:mailbox-read mbox)) - messages) - (mp:mailbox-empty-p mbox) - t)) + (and (not (mp:mailbox-empty-p mbox)) + (equalp (loop for i from 1 to l + collect (mp:mailbox-read mbox)) + messages) + (mp:mailbox-empty-p mbox) + t)) t) ;;; Date: 14/04/2012 -;;; The mailbox blocks a process when it saturates the write queue. +;;; The mailbox blocks a process when it saturates the write queue. (def-mp-test mbox-blocks-1-to-1 (let* ((flag nil) - (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32)) - (size (mp:mailbox-count mbox)) - (a-process (mp:process-run-function - "mbox-signal-one-process" - #'(lambda () - ;; This does not block - (loop for i from 1 to size - do (mp:mailbox-send mbox i)) - ;; Here we block - (setf flag t) - (mp:mailbox-send mbox (1+ size)) - ;; Now we unblock - (setf flag nil))))) + (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32)) + (size (mp:mailbox-count mbox)) + (a-process (mp:process-run-function + "mbox-signal-one-process" + #'(lambda () + ;; This does not block + (loop for i from 1 to size + do (mp:mailbox-send mbox i)) + ;; Here we block + (setf flag t) + (mp:mailbox-send mbox (1+ size)) + ;; Now we unblock + (setf flag nil))))) (sleep 0.2) ; give time for all messages to arrive (and (not (mp:mailbox-empty-p mbox)) ; the queue has messages - (mp:process-active-p a-process) ; the process is active - flag ; and it is blocked - (loop for i from 1 to (1+ size) ; messages arrive in order - always (= i (mp:mailbox-read mbox))) - (null flag) ; and process unblocked - (mp:mailbox-empty-p mbox) - t)) + (mp:process-active-p a-process) ; the process is active + flag ; and it is blocked + (loop for i from 1 to (1+ size) ; messages arrive in order + always (= i (mp:mailbox-read mbox))) + (null flag) ; and process unblocked + (mp:mailbox-empty-p mbox) + t)) t) ;;; Date: 14/04/2012 -;;; N producers and 1 consumer +;;; N producers and 1 consumer (def-mp-test mbox-n-to-1-communication (loop with length = 10000 with mbox = (mp:make-mailbox :name "mbox-n-to-1-communication" :count 128) @@ -75,24 +75,24 @@ for m = (round length n) for messages = (loop for i from 0 below (* n m) collect i) for producers = (loop for i from 0 below n - do (mp:process-run-function - "mbox-n-to-1-producer" - (let ((proc-no i)) - #'(lambda () - (loop for i from 0 below m - for msg = (+ i (* proc-no m)) - do (mp:mailbox-send mbox msg)))))) + do (mp:process-run-function + "mbox-n-to-1-producer" + (let ((proc-no i)) + #'(lambda () + (loop for i from 0 below m + for msg = (+ i (* proc-no m)) + do (mp:mailbox-send mbox msg)))))) always (and (equalp - (sort (loop for i from 1 to (* n m) - collect (mp:mailbox-read mbox)) - #'<) - messages) - (mp:mailbox-empty-p mbox))) + (sort (loop for i from 1 to (* n m) + collect (mp:mailbox-read mbox)) + #'<) + messages) + (mp:mailbox-empty-p mbox))) t) ;;; Date: 14/04/2012 -;;; 1 producer and N consumer, but they do not block, because the -;;; queue is large enough and pre-filled with messages +;;; 1 producer and N consumer, but they do not block, because the +;;; queue is large enough and pre-filled with messages (def-mp-test mbox-1-to-n-non-blocking (loop with lock = (mp:make-lock :name "mbox-1-to-n-communication") for n from 1 to 10 @@ -101,22 +101,22 @@ for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) for flags = (make-array length :initial-element nil) for aux = (loop for i from 0 below length - do (mp:mailbox-send mbox i)) + do (mp:mailbox-send mbox i)) for producers = (loop for i from 0 below n - do (mp:process-run-function - "mbox-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - for msg = (mp:mailbox-read mbox) - do (setf (aref flags msg) t))))) + do (mp:process-run-function + "mbox-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + for msg = (mp:mailbox-read mbox) + do (setf (aref flags msg) t))))) do (sleep 0.1) always (and (every #'identity flags) - (mp:mailbox-empty-p mbox))) + (mp:mailbox-empty-p mbox))) t) ;;; Date: 14/04/2012 -;;; 1 producer and N consumers, which block, because the producer -;;; is started _after_ them and is slower. +;;; 1 producer and N consumers, which block, because the producer +;;; is started _after_ them and is slower. (def-mp-test mbox-1-to-n-blocking (loop for n from 1 to 10 for m = (round 10000 n) @@ -124,16 +124,16 @@ for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length) for flags = (make-array length :initial-element nil) for producers = (loop for i from 0 below n - do (mp:process-run-function - "mbox-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - for msg = (mp:mailbox-read mbox) - do (setf (aref flags msg) t))))) + do (mp:process-run-function + "mbox-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + for msg = (mp:mailbox-read mbox) + do (setf (aref flags msg) t))))) do (loop for i from 0 below length - do (mp:mailbox-send mbox i)) + do (mp:mailbox-send mbox i)) do (sleep 0.1) always (and (every #'identity flags) - (mp:mailbox-empty-p mbox))) + (mp:mailbox-empty-p mbox))) t) diff --git a/src/tests/bugs/mop-001.lsp b/src/tests/bugs/mop-001.lsp index 992c4d534..83654fb3e 100644 --- a/src/tests/bugs/mop-001.lsp +++ b/src/tests/bugs/mop-001.lsp @@ -14,28 +14,28 @@ ;;; Fixed: 14/04/2006 (juanjo) ;;; Description: ;;; -;;; The slot definitions from some classes did not get converted. -;;; Besides, metaobject CLASS had the same list for direct and effective -;;; slots. +;;; The slot definitions from some classes did not get converted. +;;; Besides, metaobject CLASS had the same list for direct and effective +;;; slots. ;;; (deftest mop-0001-fixup (block top (labels ((test-class (class-object) - (let ((x (find-if-not #'(lambda (x) - (typep x 'standard-direct-slot-definition)) - (class-direct-slots class-object)))) - (when x - (format t "Class ~a has as direct slot ~a" class-object x) - (return-from top (class-name class-object)))) - (let ((x (find-if-not #'(lambda (x) - (typep x 'standard-effective-slot-definition)) - (class-slots class-object)))) - (when x - (format t "Class ~a has as effective slot ~a" class-object x) - (return-from top (class-name class-object)))) - (mapc #'test-class (clos::class-direct-subclasses class-object)))) - (test-class (find-class 't)) - nil)) + (let ((x (find-if-not #'(lambda (x) + (typep x 'standard-direct-slot-definition)) + (class-direct-slots class-object)))) + (when x + (format t "Class ~a has as direct slot ~a" class-object x) + (return-from top (class-name class-object)))) + (let ((x (find-if-not #'(lambda (x) + (typep x 'standard-effective-slot-definition)) + (class-slots class-object)))) + (when x + (format t "Class ~a has as effective slot ~a" class-object x) + (return-from top (class-name class-object)))) + (mapc #'test-class (clos::class-direct-subclasses class-object)))) + (test-class (find-class 't)) + nil)) nil) ;;; Date: 13/02/2006 @@ -43,16 +43,16 @@ ;;; Fixed: 24-02-2006 (juanjo) ;;; Description: ;;; -;;; Subclasses of STANDARD-CLASS would not inherit all their slots -;;; and thus would cause runtime errors when creating instances. +;;; Subclasses of STANDARD-CLASS would not inherit all their slots +;;; and thus would cause runtime errors when creating instances. ;;; (deftest mop-0002-metaclasses (eval '(progn - (defclass foo-metaclass (standard-class) ()) - (defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass)) - (prog1 (slot-value (make-instance 'faa :a 3) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) + (defclass foo-metaclass (standard-class) ()) + (defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass)) + (prog1 (slot-value (make-instance 'faa :a 3) 'a) + (cl-test::delete-class 'foo-metaclass 'faa)))) 3) ;;; Date: 02/03/2006 @@ -60,7 +60,7 @@ ;;; Fixed: 07/03/2006 (juanjo) ;;; Description: ;;; -;;; CLOS should export the symbols from the AMOP. +;;; CLOS should export the symbols from the AMOP. ;;; @@ -103,11 +103,11 @@ (deftest mop-0003-symbols (let ((*package* (find-package "CLOS"))) (and (remove-if #'(lambda (x) - (multiple-value-bind (s t) - (find-symbol x *package*) - (and s (eq t :external)))) - +mop-symbols+) - t)) + (multiple-value-bind (s t) + (find-symbol x *package*) + (and s (eq t :external)))) + +mop-symbols+) + t)) nil) ;;; Date: 02/03/2006 @@ -115,24 +115,24 @@ ;;; Fixed: 02-03-2006 (Dan Corkill) ;;; Description: ;;; -;;; DEFCLASS allows additional options which should be handled by the -;;; metaclass. +;;; DEFCLASS allows additional options which should be handled by the +;;; metaclass. ;;; (deftest mop-0004-defclass-options (eval '(let ((*aux* 5)) - (declare (special *aux*)) - (defclass foo-metaclass (standard-class) ()) - (defmethod shared-initialize ((class foo-metaclass) slot-names - &rest initargs &key option) - (prog1 (call-next-method) - (setf *aux* option))) - (defclass faa () - ((a :initform *aux* :initarg :a)) - (:metaclass foo-metaclass) - (:option t)) - (prog1 (slot-value (make-instance 'faa) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) + (declare (special *aux*)) + (defclass foo-metaclass (standard-class) ()) + (defmethod shared-initialize ((class foo-metaclass) slot-names + &rest initargs &key option) + (prog1 (call-next-method) + (setf *aux* option))) + (defclass faa () + ((a :initform *aux* :initarg :a)) + (:metaclass foo-metaclass) + (:option t)) + (prog1 (slot-value (make-instance 'faa) 'a) + (cl-test::delete-class 'foo-metaclass 'faa)))) (T)) ;;; Date: 02/03/2006 @@ -140,16 +140,16 @@ ;;; Fixed: 02-03-2006 (Dan Corkill) ;;; Description: ;;; -;;; Readers and writers for slot documentation. +;;; Readers and writers for slot documentation. ;;; (deftest mop-0004b-slot-documentation (eval '(progn - (defclass fee () - ((a :initform *aux* :initarg :a))) - (setf (documentation (first (clos:class-slots (find-class 'fee))) t) - #1="hola") - (documentation (first (clos:class-slots (find-class 'fee))) t))) + (defclass fee () + ((a :initform *aux* :initarg :a))) + (setf (documentation (first (clos:class-slots (find-class 'fee))) t) + #1="hola") + (documentation (first (clos:class-slots (find-class 'fee))) t))) #1#) ;;; Date: 25/03/2006 @@ -157,22 +157,22 @@ ;;; Fixed: 03/04/2006 (juanjo) ;;; Description: ;;; -;;; The default slot setter methods had the first argument -;;; (i.e. the new value) specialized to NIL. This makes it -;;; impossible to write further specializations. +;;; The default slot setter methods had the first argument +;;; (i.e. the new value) specialized to NIL. This makes it +;;; impossible to write further specializations. ;;; (deftest mop-0005-setf-specializer (progn (defclass fee () - ((a :accessor fee-a))) + ((a :accessor fee-a))) (prog1 - (list - (mapcar #'class-name - (method-specializers (first (generic-function-methods #'(setf fee-a))))) - (mapcar #'class-name - (method-specializers (first (generic-function-methods #'fee-a))))) - (delete-class 'fee))) + (list + (mapcar #'class-name + (method-specializers (first (generic-function-methods #'(setf fee-a))))) + (mapcar #'class-name + (method-specializers (first (generic-function-methods #'fee-a))))) + (delete-class 'fee))) ((t fee) (fee))) ;;; Date: 06/04/2006 @@ -180,19 +180,19 @@ ;;; Fixed: --- ;;; Description: ;;; -;;; When a required argument in a method is not explicitely given -;;; an specializer, the specializer should be T. Thus -;;; (defmethod foo (a)) -;;; is equivalent to -;;; (defmethod foo ((a t))) +;;; When a required argument in a method is not explicitely given +;;; an specializer, the specializer should be T. Thus +;;; (defmethod foo (a)) +;;; is equivalent to +;;; (defmethod foo ((a t))) ;;; (deftest mop-0006-method-specializer (progn (defmethod mop-0006-foo (a)) (prog1 - (method-specializers (first (generic-function-methods #'mop-0006-foo))) - (fmakunbound 'mop-0006-foo))) + (method-specializers (first (generic-function-methods #'mop-0006-foo))) + (fmakunbound 'mop-0006-foo))) (#.(find-class t))) ;;; Date: 22/04/2006 @@ -200,39 +200,39 @@ ;;; Fixed: 23/04/2006 (juanjo) ;;; Description: ;;; -;;; When a class inherits from two other classes which have a slot -;;; with the same name, the new class should inherit the accessors -;;; from both classes. +;;; When a class inherits from two other classes which have a slot +;;; with the same name, the new class should inherit the accessors +;;; from both classes. ;;; (deftest mop-0007-slot-inheritance (progn (defclass fee-1 () - ((slot-0 :initform 0 :reader slot-0) - (slot-1 :initform 1 :reader slot-1))) + ((slot-0 :initform 0 :reader slot-0) + (slot-1 :initform 1 :reader slot-1))) (defclass fee-2 () - ((slot-0 :initform 2 :reader slot-2))) + ((slot-0 :initform 2 :reader slot-2))) (defclass fee-3 (fee-1 fee-2) - ((slot-0 :initform 3 :accessor c-slot-0))) + ((slot-0 :initform 3 :accessor c-slot-0))) (flet ((accessors (class) - (list (class-name class) - (mapcar #'slot-definition-readers (class-slots class)) - (mapcar #'slot-definition-readers (class-slots class))))) - (prog1 - (list (accessors (find-class 'fee-1)) - (accessors (find-class 'fee-2)) - (accessors (find-class 'fee-3)) - (mapcar #'(lambda (o) - (mapcar #'(lambda (method) - (handler-case (funcall method o) - (error (c) nil))) - '(slot-0 slot-2 c-slot-0))) - (mapcar #'make-instance '(fee-1 fee-2 fee-3)))) - (delete-class 'fee-1 'fee-2 'fee-3)))) + (list (class-name class) + (mapcar #'slot-definition-readers (class-slots class)) + (mapcar #'slot-definition-readers (class-slots class))))) + (prog1 + (list (accessors (find-class 'fee-1)) + (accessors (find-class 'fee-2)) + (accessors (find-class 'fee-3)) + (mapcar #'(lambda (o) + (mapcar #'(lambda (method) + (handler-case (funcall method o) + (error (c) nil))) + '(slot-0 slot-2 c-slot-0))) + (mapcar #'make-instance '(fee-1 fee-2 fee-3)))) + (delete-class 'fee-1 'fee-2 'fee-3)))) ((fee-1 ((slot-0) (slot-1)) ((slot-0) (slot-1))) (fee-2 ((slot-2)) ((slot-2))) (fee-3 ((c-slot-0 slot-0 slot-2) (slot-1)) - ((c-slot-0 slot-0 slot-2) (slot-1))) + ((c-slot-0 slot-0 slot-2) (slot-1))) ((0 nil nil) (nil 2 nil) (3 3 3)))) @@ -243,26 +243,26 @@ ;;; Fixed: 05/05/2006 (P. Costanza) ;;; Description: ;;; -;;; Option names from classes and generic functions which are not -;;; in the keyword package should be quoted. This test is -;;; essentially like mop-0004-... because our DEFGENERIC does not -;;; support non-keyword options. +;;; Option names from classes and generic functions which are not +;;; in the keyword package should be quoted. This test is +;;; essentially like mop-0004-... because our DEFGENERIC does not +;;; support non-keyword options. ;;; (deftest mop-0008-defclass-option-quote (eval '(let ((*aux* 5)) - (declare (special *aux*)) - (defclass foo-metaclass (standard-class) ()) - (defmethod shared-initialize ((class foo-metaclass) slot-names - &rest initargs &key ((cl-user::option option))) - (prog1 (call-next-method) - (setf *aux* option))) - (defclass faa () - ((a :initform *aux* :initarg :a)) - (:metaclass foo-metaclass) - (cl-user::option t)) - (prog1 (slot-value (make-instance 'faa) 'a) - (cl-test::delete-class 'foo-metaclass 'faa)))) + (declare (special *aux*)) + (defclass foo-metaclass (standard-class) ()) + (defmethod shared-initialize ((class foo-metaclass) slot-names + &rest initargs &key ((cl-user::option option))) + (prog1 (call-next-method) + (setf *aux* option))) + (defclass faa () + ((a :initform *aux* :initarg :a)) + (:metaclass foo-metaclass) + (cl-user::option t)) + (prog1 (slot-value (make-instance 'faa) 'a) + (cl-test::delete-class 'foo-metaclass 'faa)))) (t)) @@ -271,20 +271,20 @@ ;;; Fixed: 10/10/2006 (juanjo) ;;; Description: ;;; -;;; :INITFORM arguments do not get properly expanded when the form -;;; is a constant variable. +;;; :INITFORM arguments do not get properly expanded when the form +;;; is a constant variable. ;;; -;;; (defclass a () ((a :initform most-positive-fixnum))) -;;; (slot-value (make-instance a) 'a) => most-positive-fixnum +;;; (defclass a () ((a :initform most-positive-fixnum))) +;;; (slot-value (make-instance a) 'a) => most-positive-fixnum ;;; (deftest mop-0009-defclass-initform (loop for quoting in '(nil t) - collect - (loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil) - collect (prog1 (eval `(progn - (defclass foo () ((a :initform ,(if quoting (list 'quote f) f)))) - (slot-value (make-instance 'foo) 'a))) - (cl-test::delete-class 'foo)))) + collect + (loop for f in '(most-positive-fixnum #1=#.(lambda () 1) 12 "hola" :a t nil) + collect (prog1 (eval `(progn + (defclass foo () ((a :initform ,(if quoting (list 'quote f) f)))) + (slot-value (make-instance 'foo) 'a))) + (cl-test::delete-class 'foo)))) ((#.most-positive-fixnum #1# 12 "hola" :a t nil) (most-positive-fixnum #1# 12 "hola" :a t nil))) diff --git a/src/tests/bugs/mop-dependents.lsp b/src/tests/bugs/mop-dependents.lsp index d71c9f8d4..d6b2d2b86 100644 --- a/src/tests/bugs/mop-dependents.lsp +++ b/src/tests/bugs/mop-dependents.lsp @@ -14,146 +14,146 @@ ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; ADD-DEPENDENT uses pushnew +;;; ADD-DEPENDENT uses pushnew ;;; (deftest mop-gf-add-non-redundant (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2) + l1 l2) (fmakunbound 'mop-gf-add/remove-dependent) (defgeneric mop-gf-add/remove-dependent (a)) (let ((f #'mop-gf-add/remove-dependent)) - (clos:add-dependent f dep) - (setf l1 (clos::generic-function-dependents f)) - (clos:add-dependent f dep) - (setf l2 (clos::generic-function-dependents f)) - (and (eq l1 l2) - (equalp l1 (list dep)) - t))) + (clos:add-dependent f dep) + (setf l1 (clos::generic-function-dependents f)) + (clos:add-dependent f dep) + (setf l2 (clos::generic-function-dependents f)) + (and (eq l1 l2) + (equalp l1 (list dep)) + t))) t) ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; Generic functions have dependents and are activated +;;; Generic functions have dependents and are activated ;;; (deftest mop-gf-add/remove-dependent (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2 l3 l4 l5 l6) + l1 l2 l3 l4 l5 l6) (fmakunbound 'mop-gf-add/remove-dependent) (defgeneric mop-gf-add/remove-dependent (a)) (let ((f #'mop-gf-add/remove-dependent) - m1 m2) - ;; - ;; * ADD-DEPENDENT registers the object with the function - ;; - (clos:add-dependent f dep) - (setf l1 (clos::generic-function-dependents f)) - ;; - ;; * ADD-METHOD invokes UPDATE-DEPENDENT - ;; - (defmethod mop-gf-add/remove-dependent ((a number)) (cos a)) - (setf l2 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT - ;; - (setf m1 (first (compute-applicable-methods f (list 1.0)))) - (remove-method f m1) - (setf l3 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-DEPENDENT eliminates all dependencies - ;; - (clos:remove-dependent f dep) - (setf l4 (clos::generic-function-dependents f)) - ;; - ;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect - ;; - (defmethod mop-gf-add/remove-dependent ((a symbol)) a) - (setf l5 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect - ;; - (setf m2 (first (compute-applicable-methods f (list 'a)))) - (setf l6 (mop-dependent-object-log dep)) - ;; the first call to defmethod adds two entries: one for the - ;; add-method and another one for a reinitialize-instance with - ;; the name of the function - (and (equalp l1 (list dep)) - (eq l2 (rest l3)) - (equalp l3 - (list (list f 'remove-method m1) - (list f 'add-method m1) - (list f :name 'mop-gf-add/remove-dependent))) - (null l4) - (eq l5 l3) - (eq l6 l3) - t))) + m1 m2) + ;; + ;; * ADD-DEPENDENT registers the object with the function + ;; + (clos:add-dependent f dep) + (setf l1 (clos::generic-function-dependents f)) + ;; + ;; * ADD-METHOD invokes UPDATE-DEPENDENT + ;; + (defmethod mop-gf-add/remove-dependent ((a number)) (cos a)) + (setf l2 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT + ;; + (setf m1 (first (compute-applicable-methods f (list 1.0)))) + (remove-method f m1) + (setf l3 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-DEPENDENT eliminates all dependencies + ;; + (clos:remove-dependent f dep) + (setf l4 (clos::generic-function-dependents f)) + ;; + ;; * ADD-METHOD invokes UPDATE-DEPENDENT but has no effect + ;; + (defmethod mop-gf-add/remove-dependent ((a symbol)) a) + (setf l5 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-METHOD invokes UPDATE-DEPENDENT but has no effect + ;; + (setf m2 (first (compute-applicable-methods f (list 'a)))) + (setf l6 (mop-dependent-object-log dep)) + ;; the first call to defmethod adds two entries: one for the + ;; add-method and another one for a reinitialize-instance with + ;; the name of the function + (and (equalp l1 (list dep)) + (eq l2 (rest l3)) + (equalp l3 + (list (list f 'remove-method m1) + (list f 'add-method m1) + (list f :name 'mop-gf-add/remove-dependent))) + (null l4) + (eq l5 l3) + (eq l6 l3) + t))) t) ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; ADD-DEPENDENT does not duplicate elements +;;; ADD-DEPENDENT does not duplicate elements ;;; (deftest mop-class-add/remove-dependent (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2) + l1 l2) (when (find-class 'mop-class-add/remove-dependent nil) - (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) + (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) (defclass mop-class-add/remove-dependent () ()) (let ((f (find-class 'mop-class-add/remove-dependent))) - (clos:add-dependent f dep) - (setf l1 (clos::class-dependents f)) - (clos:add-dependent f dep) - (setf l2 (clos::class-dependents f)) - (and (eq l1 l2) - (equalp l1 (list dep)) - t))) + (clos:add-dependent f dep) + (setf l1 (clos::class-dependents f)) + (clos:add-dependent f dep) + (setf l2 (clos::class-dependents f)) + (and (eq l1 l2) + (equalp l1 (list dep)) + t))) t) ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; Standard classes have dependents and are activated +;;; Standard classes have dependents and are activated ;;; (deftest mop-class-add/remove-dependent (let* ((dep (make-instance 'mop-dependent-object)) - l1 l2 l3 l4 l5) + l1 l2 l3 l4 l5) (when (find-class 'mop-class-add/remove-dependent nil) - (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) + (setf (class-name (find-class 'mop-class-add/remove-dependent)) nil)) (defclass mop-class-add/remove-dependent () ()) (let ((f (find-class 'mop-class-add/remove-dependent))) - ;; - ;; * ADD-DEPENDENT registers the object with the class - ;; - (clos:add-dependent f dep) - (setf l1 (clos::class-dependents f)) - ;; - ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT - ;; - (defclass mop-class-add/remove-dependent () (a)) - (setf l2 (clos::class-dependents f)) - (setf l3 (mop-dependent-object-log dep)) - ;; - ;; * REMOVE-DEPENDENT eliminates object from list - ;; - (clos:remove-dependent f dep) - (setf l4 (clos::class-dependents f)) - ;; - ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect - ;; - (defclass mop-class-add/remove-dependent () ()) - (setf l5 (mop-dependent-object-log dep)) - ;; - ;; the first call to defclass adds one entry with the reinitialization - ;; of the class both in name and list of slots - (and (equalp l1 (list dep)) - (eq l1 l2) - (equalp l3 - (list (list f :name 'mop-class-add/remove-dependent - :direct-superclasses nil - :direct-slots '((:name a))))) - (null l4) - (eq l5 l3) - t))) + ;; + ;; * ADD-DEPENDENT registers the object with the class + ;; + (clos:add-dependent f dep) + (setf l1 (clos::class-dependents f)) + ;; + ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT + ;; + (defclass mop-class-add/remove-dependent () (a)) + (setf l2 (clos::class-dependents f)) + (setf l3 (mop-dependent-object-log dep)) + ;; + ;; * REMOVE-DEPENDENT eliminates object from list + ;; + (clos:remove-dependent f dep) + (setf l4 (clos::class-dependents f)) + ;; + ;; * SHARED-INITIALIZE invokes UPDATE-DEPENDENT without effect + ;; + (defclass mop-class-add/remove-dependent () ()) + (setf l5 (mop-dependent-object-log dep)) + ;; + ;; the first call to defclass adds one entry with the reinitialization + ;; of the class both in name and list of slots + (and (equalp l1 (list dep)) + (eq l1 l2) + (equalp l3 + (list (list f :name 'mop-class-add/remove-dependent + :direct-superclasses nil + :direct-slots '((:name a))))) + (null l4) + (eq l5 l3) + t))) t) diff --git a/src/tests/bugs/mop-dispatch.lsp b/src/tests/bugs/mop-dispatch.lsp index 875333722..abaa4aa07 100644 --- a/src/tests/bugs/mop-dispatch.lsp +++ b/src/tests/bugs/mop-dispatch.lsp @@ -8,162 +8,162 @@ ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and -;;; two methods and no EQL. +;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES works with one and +;;; two methods and no EQL. ;;; (deftest mop-c-a-m-u-c-two-methods (progn (fmakunbound 'mop-fn) (defgeneric mop-fn (a) - (:method ((a number)) (cos a)) - (:method ((a symbol)) a)) + (:method ((a number)) (cos a)) + (:method ((a symbol)) a)) (let ((m1 (compute-applicable-methods #'mop-fn (list 1.0))) - (m2 (compute-applicable-methods #'mop-fn (list 'a)))) - (flet ((f (class) - (multiple-value-list (clos:compute-applicable-methods-using-classes - #'mop-fn (list (find-class class)))))) - (and (equalp (f 'number) (list m1 t)) - (equalp (f 'real) (list m1 t)) - (equalp (f 'symbol) (list m2 t)) - (equalp (f 'cons) '(nil t)) - t)))) + (m2 (compute-applicable-methods #'mop-fn (list 'a)))) + (flet ((f (class) + (multiple-value-list (clos:compute-applicable-methods-using-classes + #'mop-fn (list (find-class class)))))) + (and (equalp (f 'number) (list m1 t)) + (equalp (f 'real) (list m1 t)) + (equalp (f 'symbol) (list m2 t)) + (equalp (f 'cons) '(nil t)) + t)))) t) ;;; Date: 23/04/2012 ;;; Description: ;;; -;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL specializers -;;; when one of the specializers is covered by the classes. +;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES fails with EQL specializers +;;; when one of the specializers is covered by the classes. ;;; (deftest mop-c-a-m-u-c-fails-with-eql (progn (fmakunbound 'mop-fn) (defgeneric mop-fn (a) - (:method ((a (eql 1))) 1) - (:method ((a (eql 'a))) 2) - (:method ((a float)) 3)) + (:method ((a (eql 1))) 1) + (:method ((a (eql 'a))) 2) + (:method ((a float)) 3)) (let ((m1 (compute-applicable-methods #'mop-fn (list 1))) - (m2 (compute-applicable-methods #'mop-fn (list 'a))) - (m3 (compute-applicable-methods #'mop-fn (list 1.0)))) - (flet ((f (class) - (multiple-value-list (clos:compute-applicable-methods-using-classes - #'mop-fn (list (find-class class)))))) - (and (equalp (f 'integer) (list nil nil)) - (equalp (f 'number) (list nil nil)) - (equalp (f 'symbol) (list nil nil)) - (equalp (f 'float) (list m3 t)) - (= (length m1) 1) - (= (length m2) 1) - (= (length m3) 1) - t)))) + (m2 (compute-applicable-methods #'mop-fn (list 'a))) + (m3 (compute-applicable-methods #'mop-fn (list 1.0)))) + (flet ((f (class) + (multiple-value-list (clos:compute-applicable-methods-using-classes + #'mop-fn (list (find-class class)))))) + (and (equalp (f 'integer) (list nil nil)) + (equalp (f 'number) (list nil nil)) + (equalp (f 'symbol) (list nil nil)) + (equalp (f 'float) (list m3 t)) + (= (length m1) 1) + (= (length m2) 1) + (= (length m3) 1) + t)))) t) ;;; Date: 24/04/2012 ;;; Description: ;;; -;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL. +;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked and honored by ECL. ;;; (deftest mop-discriminator (progn (fmakunbound 'foo) (defclass my-generic-function (standard-generic-function) - ()) + ()) (defmethod clos:compute-discriminating-function ((gf my-generic-function)) - ;; We compute the invocaions of c-d-f. Note that it is invoked - ;; quite often -- we could probably optimize this. - #'(lambda (&rest args) - args)) + ;; We compute the invocaions of c-d-f. Note that it is invoked + ;; quite often -- we could probably optimize this. + #'(lambda (&rest args) + args)) (defgeneric foo (a) - (:generic-function-class my-generic-function)) + (:generic-function-class my-generic-function)) (unwind-protect - (foo 2) - (fmakunbound 'foo))) + (foo 2) + (fmakunbound 'foo))) (2)) ;;; Date: 24/04/2012 ;;; Description: ;;; -;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD, -;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on -;;; generic functions. +;;; COMPUTE-DISCRIMINATING-FUNCTION is invoked on ADD-METHOD, REMOVE-METHOD, +;;; DEFGENERIC, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE acting on +;;; generic functions. ;;; (deftest mop-discriminator-recomputation (progn (defparameter *mop-discriminator-recomputation* 0) (fmakunbound 'foo) (defclass my-generic-function (standard-generic-function) - ()) + ()) (defmethod clos:compute-discriminating-function ((gf my-generic-function)) - ;; We compute the invocaions of c-d-f. Note that it is invoked - ;; quite often -- we could probably optimize this. - (incf *mop-discriminator-recomputation*) - (call-next-method)) + ;; We compute the invocaions of c-d-f. Note that it is invoked + ;; quite often -- we could probably optimize this. + (incf *mop-discriminator-recomputation*) + (call-next-method)) (and (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(defgeneric foo (a) - (:generic-function-class my-generic-function))) - (plusp *mop-discriminator-recomputation* )) - (typep #'foo 'my-generic-function) - (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(defmethod foo ((a number)) (print a))) - (plusp *mop-discriminator-recomputation*)) - (progn - (setf *mop-discriminator-recomputation* 0) - (eval '(remove-method #'foo (first (compute-applicable-methods - #'foo - (list 1.0))))) - (plusp *mop-discriminator-recomputation*)) - t)) + (setf *mop-discriminator-recomputation* 0) + (eval '(defgeneric foo (a) + (:generic-function-class my-generic-function))) + (plusp *mop-discriminator-recomputation* )) + (typep #'foo 'my-generic-function) + (progn + (setf *mop-discriminator-recomputation* 0) + (eval '(defmethod foo ((a number)) (print a))) + (plusp *mop-discriminator-recomputation*)) + (progn + (setf *mop-discriminator-recomputation* 0) + (eval '(remove-method #'foo (first (compute-applicable-methods + #'foo + (list 1.0))))) + (plusp *mop-discriminator-recomputation*)) + t)) t) ;;; Date: 24/04/2012 ;;; Description: ;;; -;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for -;;; user-defined generic function classes. +;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS-USING-CLASSES for +;;; user-defined generic function classes. ;;; (deftest mop-compute-applicable-methods-using-classes-is-honored (progn (defparameter *mop-dispatch-used* 0) (fmakunbound 'foo) (defclass my-generic-function (standard-generic-function) - ()) + ()) (defmethod clos:compute-applicable-methods-using-classes - ((gf my-generic-function) classes) - (incf *mop-dispatch-used*) - (call-next-method)) + ((gf my-generic-function) classes) + (incf *mop-dispatch-used*) + (call-next-method)) (defgeneric foo (a) - (:generic-function-class my-generic-function) - (:method ((a number)) (cos 1.0))) + (:generic-function-class my-generic-function) + (:method ((a number)) (cos 1.0))) (and (zerop *mop-dispatch-used*) - (progn (foo 1.0) (plusp *mop-dispatch-used*)))) + (progn (foo 1.0) (plusp *mop-dispatch-used*)))) t) ;;; Date: 24/04/2012 ;;; Description: ;;; -;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for -;;; user-defined generic function classes. +;;; Verify ECL calls COMPUTE-APPLICABLE-METHODS for +;;; user-defined generic function classes. ;;; (deftest mop-compute-applicable-methods-is-honored (progn (defparameter *mop-dispatch-used* 0) (fmakunbound 'foo) (defclass my-generic-function (standard-generic-function) - ()) + ()) (defmethod clos:compute-applicable-methods-using-classes - ((gf my-generic-function) classes) - (incf *mop-dispatch-used*) - (values nil nil)) + ((gf my-generic-function) classes) + (incf *mop-dispatch-used*) + (values nil nil)) (defmethod compute-applicable-methods - ((gf my-generic-function) args) - (incf *mop-dispatch-used*) - (call-next-method)) + ((gf my-generic-function) args) + (incf *mop-dispatch-used*) + (call-next-method)) (defgeneric foo (a) - (:generic-function-class my-generic-function) - (:method ((a number)) (cos 1.0))) + (:generic-function-class my-generic-function) + (:method ((a number)) (cos 1.0))) (and (zerop *mop-dispatch-used*) - (progn (foo 1.0) (= *mop-dispatch-used* 2)))) + (progn (foo 1.0) (= *mop-dispatch-used* 2)))) t) diff --git a/src/tests/bugs/mp-001.lsp b/src/tests/bugs/mp-001.lsp index 53fb4643c..26e347bab 100644 --- a/src/tests/bugs/mp-001.lsp +++ b/src/tests/bugs/mp-001.lsp @@ -10,35 +10,35 @@ ;;; Fixed: 05/09/2009 (Juanjo) ;;; Description: ;;; -;;; When a WITH-LOCK is interrupted, it is not able to release -;;; the resulting lock and an error is signaled. +;;; When a WITH-LOCK is interrupted, it is not able to release +;;; the resulting lock and an error is signaled. ;;; (def-mp-test mp-0001-with-lock (let ((flag t) - (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil))) + (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil))) (mp:with-lock (lock) (let ((background-process (mp:process-run-function "mp-0001-with-lock" #'(lambda () - (handler-case - (progn - (setf flag 1) - (mp:with-lock (lock) - (setf flag 2))) - (error (c) - (princ c)(terpri) - (setf flag c))) - (setf flag 2))))) + (handler-case + (progn + (setf flag 1) + (mp:with-lock (lock) + (setf flag 2))) + (error (c) + (princ c)(terpri) + (setf flag c))) + (setf flag 2))))) ;; The background process should not be able to get ;; the lock, and will simply wait. Now we interrupt it ;; and the process should gracefully quit, without ;; signalling any serious condition (and (progn (sleep 1) - (mp:process-kill background-process)) + (mp:process-kill background-process)) (progn (sleep 1) (not (mp:process-active-p background-process))) (eq flag 1) - t)))) - t) \ No newline at end of file + t)))) + t) diff --git a/src/tests/bugs/mp-tools.lsp b/src/tests/bugs/mp-tools.lsp index 91536015f..8fb39c1c5 100644 --- a/src/tests/bugs/mp-tools.lsp +++ b/src/tests/bugs/mp-tools.lsp @@ -15,25 +15,25 @@ it may block hard the lisp image." (mapc #'mp:process-kill process-list) (when wait (loop for i in process-list - do (mp:process-join i))) + do (mp:process-join i))) process-list)) (defun mp-test-run (closure) (let* ((all-processes (mp:all-processes)) - (output (multiple-value-list (funcall closure)))) + (output (multiple-value-list (funcall closure)))) (sleep 0.2) ; time to exit some processes (let ((leftovers (kill-and-wait (mp:all-processes) all-processes))) (cond (leftovers - (format t "~%;;; Stray processes: ~A" leftovers)) - (t - (values-list output)))))) + (format t "~%;;; Stray processes: ~A" leftovers)) + (t + (values-list output)))))) (defmacro def-mp-test (name body expected-value) "Runs some test code and only returns the output when the code exited without creating stray processes." (let ((all-processes (gensym)) - (output (gensym)) - (leftover (gensym))) + (output (gensym)) + (leftover (gensym))) `(deftest ,name - (mp-test-run #'(lambda () ,body)) + (mp-test-run #'(lambda () ,body)) ,expected-value))) diff --git a/src/tests/bugs/mutex-001.lsp b/src/tests/bugs/mutex-001.lsp index ea29cba4c..627032148 100644 --- a/src/tests/bugs/mutex-001.lsp +++ b/src/tests/bugs/mutex-001.lsp @@ -6,16 +6,16 @@ (in-package :cl-test) ;;; Date: 12/04/2012 -;;; Non-recursive mutexes should signal an error when they -;;; cannot be relocked. +;;; Non-recursive mutexes should signal an error when they +;;; cannot be relocked. (deftest mutex-001-recursive-error (let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error))) (and (mp:get-lock mutex) (eq (mp:lock-owner mutex) mp:*current-process*) (handler-case - (progn (mp:get-lock mutex) nil) - (error (c) t)) + (progn (mp:get-lock mutex) nil) + (error (c) t)) (mp:giveup-lock mutex) (null (mp:lock-owner mutex)) (zerop (mp:lock-count mutex)) @@ -23,18 +23,18 @@ t) ;;; Date: 12/04/2012 -;;; Recursive locks increase the counter. +;;; Recursive locks increase the counter. (deftest mutex-002-recursive-count (let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t))) (and (loop for i from 1 upto 10 - always (and (mp:get-lock mutex) - (= (mp:lock-count mutex) i) - (eq (mp:lock-owner mutex) mp:*current-process*))) + always (and (mp:get-lock mutex) + (= (mp:lock-count mutex) i) + (eq (mp:lock-owner mutex) mp:*current-process*))) (loop for i from 9 downto 0 - always (and (eq (mp:lock-owner mutex) mp:*current-process*) - (mp:giveup-lock mutex) - (= (mp:lock-count mutex) i))) + always (and (eq (mp:lock-owner mutex) mp:*current-process*) + (mp:giveup-lock mutex) + (= (mp:lock-count mutex) i))) (null (mp:lock-owner mutex)) (zerop (mp:lock-count mutex)) t)) @@ -42,68 +42,68 @@ ;;; Date: 12/04/2012 -;;; When multiple threads compete for a mutex, they should -;;; all get the same chance of accessing the resource +;;; When multiple threads compete for a mutex, they should +;;; all get the same chance of accessing the resource ;;; (def-mp-test mutex-003-fairness (let* ((mutex (mp:make-lock :name 'mutex-001-fairness)) - (nthreads 10) - (count 10) - (counter (* nthreads count)) - (array (make-array count :element-type 'fixnum :initial-element 0))) + (nthreads 10) + (count 10) + (counter (* nthreads count)) + (array (make-array count :element-type 'fixnum :initial-element 0))) (flet ((slave (n) - (loop with continue = t - for i from 1 by 1 - while continue do - (mp:get-lock mutex) - (cond ((plusp counter) - (decf counter) - (setf (aref array n) i)) - (t - (setf continue nil))) - (mp:giveup-lock mutex)))) - ;; Launch all agents. They will be locked - (let ((all-processes - (mp:with-lock (mutex) - (loop for n from 0 below nthreads - collect (mp:process-run-function n #'slave n) - ;; ... and give them some time to block on this mutex - finally (sleep 1))))) - ;; Now they are released and operate. They should all have - ;; the same share of counts. - (loop for p in all-processes - do (mp:process-join p)) - (loop for i from 0 below nthreads - always (= (aref array i) count))))) + (loop with continue = t + for i from 1 by 1 + while continue do + (mp:get-lock mutex) + (cond ((plusp counter) + (decf counter) + (setf (aref array n) i)) + (t + (setf continue nil))) + (mp:giveup-lock mutex)))) + ;; Launch all agents. They will be locked + (let ((all-processes + (mp:with-lock (mutex) + (loop for n from 0 below nthreads + collect (mp:process-run-function n #'slave n) + ;; ... and give them some time to block on this mutex + finally (sleep 1))))) + ;; Now they are released and operate. They should all have + ;; the same share of counts. + (loop for p in all-processes + do (mp:process-join p)) + (loop for i from 0 below nthreads + always (= (aref array i) count))))) t) ;;; Date: 12/04/2012 -;;; It is possible to kill processes waiting for a lock. We launch a lot of -;;; processes, 50% of which are zombies: they acquire the lock and do not -;;; do anything. These processes are then killed, resulting in the others -;;; doing their job. +;;; It is possible to kill processes waiting for a lock. We launch a lot of +;;; processes, 50% of which are zombies: they acquire the lock and do not +;;; do anything. These processes are then killed, resulting in the others +;;; doing their job. ;;; (def-mp-test mutex-004-interruptible (let* ((mutex (mp:make-lock :name "mutex-003-fairness")) - (nprocesses 20) - (counter 0)) + (nprocesses 20) + (counter 0)) (flet ((normal-thread () - (mp:with-lock (mutex) - (incf counter))) - (zombie-thread () - (mp:with-lock (mutex) - (loop (sleep 10))))) - (let* ((all-processes (loop for i from 0 below nprocesses - for zombie = (zerop (mod i 2)) - for fn = (if zombie #'zombie-thread #'normal-thread) - collect (cons zombie - (mp:process-run-function - "mutex-003-fairness" - fn)))) - (zombies (mapcar #'cdr (remove-if-not #'car all-processes)))) - (and (zerop counter) ; No proces works because the first one is a zombie - (kill-and-wait zombies) - (progn (sleep 0.2) (= counter (/ nprocesses 2))) - (not (mp:lock-owner mutex)) - t)))) + (mp:with-lock (mutex) + (incf counter))) + (zombie-thread () + (mp:with-lock (mutex) + (loop (sleep 10))))) + (let* ((all-processes (loop for i from 0 below nprocesses + for zombie = (zerop (mod i 2)) + for fn = (if zombie #'zombie-thread #'normal-thread) + collect (cons zombie + (mp:process-run-function + "mutex-003-fairness" + fn)))) + (zombies (mapcar #'cdr (remove-if-not #'car all-processes)))) + (and (zerop counter) ; No proces works because the first one is a zombie + (kill-and-wait zombies) + (progn (sleep 0.2) (= counter (/ nprocesses 2))) + (not (mp:lock-owner mutex)) + t)))) t) diff --git a/src/tests/bugs/num-001.lsp b/src/tests/bugs/num-001.lsp index eb1e6900d..23810770b 100644 --- a/src/tests/bugs/num-001.lsp +++ b/src/tests/bugs/num-001.lsp @@ -10,7 +10,7 @@ ;;; Fixed: 10/08/2008 ;;; Description: ;;; -;;; COS, SIN and TAN were expanded using a wrong C expression. +;;; COS, SIN and TAN were expanded using a wrong C expression. ;;; (deftest num-0001-inline-cos diff --git a/src/tests/bugs/sem-001.lsp b/src/tests/bugs/sem-001.lsp index 3459899c5..e0adfe1cc 100644 --- a/src/tests/bugs/sem-001.lsp +++ b/src/tests/bugs/sem-001.lsp @@ -6,178 +6,178 @@ (in-package :cl-test) ;;; Date: 14/04/2012 -;;; Ensure that at creation name and counter are set +;;; Ensure that at creation name and counter are set (deftest sem-make-and-counter (loop with name = "sem-make-and-counter" for count from 0 to 10 for sem = (mp:make-semaphore :name name :count count) always (and (eq (mp:semaphore-name sem) name) - (= (mp:semaphore-count sem) count) - (zerop (mp:semaphore-wait-count sem)))) + (= (mp:semaphore-count sem) count) + (zerop (mp:semaphore-wait-count sem)))) t) ;;; Date: 14/04/2012 -;;; Ensure that signal changes the counter by the specified amount +;;; Ensure that signal changes the counter by the specified amount (deftest sem-signal-semaphore-count (loop with name = "sem-signal-semaphore-count" for count from 0 to 10 always (loop for delta from 0 to 10 - for sem = (mp:make-semaphore :name name :count count) - always (and (= (mp:semaphore-count sem) count) - (null (mp:signal-semaphore sem delta)) - (= (mp:semaphore-count sem ) (+ count delta))))) + for sem = (mp:make-semaphore :name name :count count) + always (and (= (mp:semaphore-count sem) count) + (null (mp:signal-semaphore sem delta)) + (= (mp:semaphore-count sem ) (+ count delta))))) t) ;;; Date: 14/04/2012 -;;; A semaphore with a count of zero blocks a process +;;; A semaphore with a count of zero blocks a process (def-mp-test sem-signal-one-process (let* ((flag nil) - (sem (mp:make-semaphore :name "sem-signal-one")) - (a-process (mp:process-run-function - "sem-signal-one-process" - #'(lambda () - (mp:wait-on-semaphore sem) - (setf flag t))))) + (sem (mp:make-semaphore :name "sem-signal-one")) + (a-process (mp:process-run-function + "sem-signal-one-process" + #'(lambda () + (mp:wait-on-semaphore sem) + (setf flag t))))) (and (null flag) - (mp:process-active-p a-process) - (progn (mp:signal-semaphore sem) (sleep 0.2) flag) - (= (mp:semaphore-count sem) 0))) + (mp:process-active-p a-process) + (progn (mp:signal-semaphore sem) (sleep 0.2) flag) + (= (mp:semaphore-count sem) 0))) t) ;;; Date: 14/04/2012 -;;; We can signal multiple processes +;;; We can signal multiple processes (def-mp-test sem-signal-n-processes (loop for count from 1 upto 10 always - (let* ((counter 0) - (lock (mp:make-lock :name "sem-signal-n-processes")) - (sem (mp:make-semaphore :name "sem-signal-n-processs")) - (all-process - (loop for i from 1 upto count - collect (mp:process-run-function - "sem-signal-n-processes" - #'(lambda () - (mp:wait-on-semaphore sem) - (mp:with-lock (lock) (incf counter))))))) - (and (zerop counter) - (every #'mp:process-active-p all-process) - (= (mp:semaphore-wait-count sem) count) - (progn (mp:signal-semaphore sem count) (sleep 0.2) - (= counter count)) - (= (mp:semaphore-count sem) 0)))) + (let* ((counter 0) + (lock (mp:make-lock :name "sem-signal-n-processes")) + (sem (mp:make-semaphore :name "sem-signal-n-processs")) + (all-process + (loop for i from 1 upto count + collect (mp:process-run-function + "sem-signal-n-processes" + #'(lambda () + (mp:wait-on-semaphore sem) + (mp:with-lock (lock) (incf counter))))))) + (and (zerop counter) + (every #'mp:process-active-p all-process) + (= (mp:semaphore-wait-count sem) count) + (progn (mp:signal-semaphore sem count) (sleep 0.2) + (= counter count)) + (= (mp:semaphore-count sem) 0)))) t) ;;; Date: 14/04/2012 -;;; When we signal N processes and N+M are waiting, only N awake +;;; When we signal N processes and N+M are waiting, only N awake (def-mp-test sem-signal-only-n-processes (loop for m from 1 upto 3 always (loop for n from 1 upto 4 always - (let* ((counter 0) - (lock (mp:make-lock :name "sem-signal-n-processes")) - (sem (mp:make-semaphore :name "sem-signal-n-processs")) - (all-process - (loop for i from 1 upto (+ n m) - collect (mp:process-run-function - "sem-signal-n-processes" - #'(lambda () - (mp:wait-on-semaphore sem) - (mp:with-lock (lock) (incf counter))))))) - (and (zerop counter) - (every #'mp:process-active-p all-process) - (= (mp:semaphore-wait-count sem) (+ m n)) - (progn (mp:signal-semaphore sem n) (sleep 0.02) - (= counter n)) - (= (mp:semaphore-wait-count sem) m) - (progn (mp:signal-semaphore sem m) (sleep 0.02) - (= counter (+ n m))) - )))) + (let* ((counter 0) + (lock (mp:make-lock :name "sem-signal-n-processes")) + (sem (mp:make-semaphore :name "sem-signal-n-processs")) + (all-process + (loop for i from 1 upto (+ n m) + collect (mp:process-run-function + "sem-signal-n-processes" + #'(lambda () + (mp:wait-on-semaphore sem) + (mp:with-lock (lock) (incf counter))))))) + (and (zerop counter) + (every #'mp:process-active-p all-process) + (= (mp:semaphore-wait-count sem) (+ m n)) + (progn (mp:signal-semaphore sem n) (sleep 0.02) + (= counter n)) + (= (mp:semaphore-wait-count sem) m) + (progn (mp:signal-semaphore sem m) (sleep 0.02) + (= counter (+ n m))) + )))) t) ;;; Date: 14/04/2012 -;;; It is possible to kill processes waiting for a semaphore. +;;; It is possible to kill processes waiting for a semaphore. ;;; (def-mp-test sem-interruptible (loop with sem = (mp:make-semaphore :name "sem-interruptible") with flag = nil for count from 1 to 10 for all-processes = (loop for i from 1 upto count - collect (mp:process-run-function - "sem-interruptible" - #'(lambda () - (mp:wait-on-semaphore sem) - (setf flag t)))) + collect (mp:process-run-function + "sem-interruptible" + #'(lambda () + (mp:wait-on-semaphore sem) + (setf flag t)))) always (and (progn (sleep 0.2) (null flag)) - (every #'mp:process-active-p all-processes) - (= (mp:semaphore-wait-count sem) count) - (mapc #'mp:process-kill all-processes) - (progn (sleep 0.2) (notany #'mp:process-active-p all-processes)) - (null flag) - (zerop (mp:semaphore-wait-count sem)) - t)) + (every #'mp:process-active-p all-processes) + (= (mp:semaphore-wait-count sem) count) + (mapc #'mp:process-kill all-processes) + (progn (sleep 0.2) (notany #'mp:process-active-p all-processes)) + (null flag) + (zerop (mp:semaphore-wait-count sem)) + t)) t) ;;; Date: 14/04/2012 -;;; When we kill a process, it is removed from the wait queue. +;;; When we kill a process, it is removed from the wait queue. ;;; (def-mp-test sem-interrupt-updates-queue (let* ((sem (mp:make-semaphore :name "sem-interrupt-updates-queue")) - (process (mp:process-run-function - "sem-interrupt-updates-queue" - #'(lambda () (mp:wait-on-semaphore sem))))) + (process (mp:process-run-function + "sem-interrupt-updates-queue" + #'(lambda () (mp:wait-on-semaphore sem))))) (sleep 0.2) (and (= (mp:semaphore-wait-count sem) 1) - (mp:process-active-p process) - (progn (mp:process-kill process) - (sleep 0.2) - (not (mp:process-active-p process))) - (zerop (mp:semaphore-wait-count sem)) - t)) + (mp:process-active-p process) + (progn (mp:process-kill process) + (sleep 0.2) + (not (mp:process-active-p process))) + (zerop (mp:semaphore-wait-count sem)) + t)) t) ;;; Date: 14/04/2012 -;;; When we kill a process, it signals another one. This is tricky, +;;; When we kill a process, it signals another one. This is tricky, ;;; because we need the awake signal to arrive _after_ the process is -;;; killed, but the process must still be in the queue for the semaphore -;;; to awake it. The way we solve this is by intercepting the kill signal. +;;; killed, but the process must still be in the queue for the semaphore +;;; to awake it. The way we solve this is by intercepting the kill signal. ;;; (def-mp-test sem-interrupted-resignals (let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals")) - (flag1 nil) - (flag2 nil) - (process1 (mp:process-run-function - "sem-interrupted-resignals" - #'(lambda () - (unwind-protect - (mp:wait-on-semaphore sem) - (sleep 4) - (setf flag1 t) - )))) - (process2 (mp:process-run-function - "sem-interrupted-resignals" - #'(lambda () - (mp:wait-on-semaphore sem) - (setf flag2 t))))) + (flag1 nil) + (flag2 nil) + (process1 (mp:process-run-function + "sem-interrupted-resignals" + #'(lambda () + (unwind-protect + (mp:wait-on-semaphore sem) + (sleep 4) + (setf flag1 t) + )))) + (process2 (mp:process-run-function + "sem-interrupted-resignals" + #'(lambda () + (mp:wait-on-semaphore sem) + (setf flag2 t))))) (sleep 0.2) (and (= (mp:semaphore-wait-count sem) 2) - (mp:process-active-p process1) - (mp:process-active-p process2) - ;; We kill the process but ensure it is still running - (progn (mp:process-kill process1) - (mp:process-active-p process1)) - (null flag1) - ;; ... and in the queue - (= (mp:semaphore-wait-count sem) 2) - ;; We awake it and it should awake the other one - (progn (format t "~%;;; Signaling semaphore") - (mp:signal-semaphore sem) - (sleep 1) - (zerop (mp:semaphore-wait-count sem))) - flag2 - t)) + (mp:process-active-p process1) + (mp:process-active-p process2) + ;; We kill the process but ensure it is still running + (progn (mp:process-kill process1) + (mp:process-active-p process1)) + (null flag1) + ;; ... and in the queue + (= (mp:semaphore-wait-count sem) 2) + ;; We awake it and it should awake the other one + (progn (format t "~%;;; Signaling semaphore") + (mp:signal-semaphore sem) + (sleep 1) + (zerop (mp:semaphore-wait-count sem))) + flag2 + t)) t) ;;; Date: 14/04/2012 -;;; 1 producer and N consumers, non-blocking, because the initial count -;;; is larger than the consumed data. +;;; 1 producer and N consumers, non-blocking, because the initial count +;;; is larger than the consumed data. (def-mp-test sem-1-to-n-non-blocking (loop with counter = 0 with lock = (mp:make-lock :name "sem-1-to-n-communication") @@ -186,22 +186,22 @@ for length = (* n m) for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count length) for producers = (progn - (setf counter 0) - (loop for i from 0 below n - collect (mp:process-run-function - "sem-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - do (mp:wait-on-semaphore sem) - do (mp:with-lock (lock) (incf counter))))))) + (setf counter 0) + (loop for i from 0 below n + collect (mp:process-run-function + "sem-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + do (mp:wait-on-semaphore sem) + do (mp:with-lock (lock) (incf counter))))))) do (mapc #'mp:process-join producers) always (and (= counter length) - (zerop (mp:semaphore-count sem)) - (zerop (mp:semaphore-wait-count sem)))) + (zerop (mp:semaphore-count sem)) + (zerop (mp:semaphore-wait-count sem)))) t) ;;; Date: 14/04/2012 -;;; 1 producer and N consumers, blocking due to a slow producer. +;;; 1 producer and N consumers, blocking due to a slow producer. (def-mp-test sem-1-to-n-blocking (loop with lock = (mp:make-lock :name "sem-1-to-n-communication") for n from 1 to 10 @@ -210,17 +210,17 @@ for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count 0) for counter = 0 for producers = (loop for i from 0 below n - collect (mp:process-run-function - "sem-1-to-n-consumer" - #'(lambda () - (loop for i from 0 below m - do (mp:wait-on-semaphore sem)) - (mp:with-lock (lock) (incf counter))))) + collect (mp:process-run-function + "sem-1-to-n-consumer" + #'(lambda () + (loop for i from 0 below m + do (mp:wait-on-semaphore sem)) + (mp:with-lock (lock) (incf counter))))) do (loop for i from 0 below length - do (mp:signal-semaphore sem)) + do (mp:signal-semaphore sem)) do (mapc #'mp:process-join producers) always (and (= counter n) - (zerop (mp:semaphore-count sem)) - (zerop (mp:semaphore-wait-count sem)))) + (zerop (mp:semaphore-count sem)) + (zerop (mp:semaphore-wait-count sem)))) t) -4 \ No newline at end of file +4 diff --git a/src/tests/bugs/tools.lsp b/src/tests/bugs/tools.lsp index b072905b9..23a4164f9 100644 --- a/src/tests/bugs/tools.lsp +++ b/src/tests/bugs/tools.lsp @@ -5,40 +5,40 @@ (defmacro with-dflet (functions &body body) "Syntax: - (with-dflet ((fname form*)*) body) + (with-dflet ((fname form*)*) body) Evaluate BODY in an environment in which the function FNAME has been redefined to evaluate the given forms _before_ executing the orginal code." (let ((vars '()) (in-forms '()) (out-forms '())) (loop for (name . forms) in functions - do (let ((var (gensym))) - (push `(,var #',name) vars) - (push `(setf (fdefinition ',name) - #'(lambda (&rest args) ,@forms (apply ,var args))) - in-forms) - (push `(setf (fdefinition ',name) ,var) out-forms))) + do (let ((var (gensym))) + (push `(,var #',name) vars) + (push `(setf (fdefinition ',name) + #'(lambda (&rest args) ,@forms (apply ,var args))) + in-forms) + (push `(setf (fdefinition ',name) ,var) out-forms))) `(let ,vars (unwind-protect - (progn ,@in-forms ,@body) - (progn ,@out-forms))))) + (progn ,@in-forms ,@body) + (progn ,@out-forms))))) (defmacro with-compiler ((filename &rest compiler-args) &body forms) "Create a lisp file with the given forms and compile it. The forms are evaluated. The output is stored in a string and output as a second value." `(progn (with-open-file (s ,filename :direction :output :if-exists :supersede - :if-does-not-exist :create) + :if-does-not-exist :create) ,@(loop for f in forms collect `(print ,f s))) (let* ((ok t) - (output - (with-output-to-string (*standard-output*) - (let ((*error-output* *standard-output*) - (*compile-verbose* t) - (*compile-print* t) - #-ecl-bytecmp - (c::*suppress-compiler-warnings* nil) - #-ecl-bytecmp - (c::*suppress-compiler-notes* nil)) - (setf ok (compile-file ,filename ,@compiler-args)))))) + (output + (with-output-to-string (*standard-output*) + (let ((*error-output* *standard-output*) + (*compile-verbose* t) + (*compile-print* t) + #-ecl-bytecmp + (c::*suppress-compiler-warnings* nil) + #-ecl-bytecmp + (c::*suppress-compiler-notes* nil)) + (setf ok (compile-file ,filename ,@compiler-args)))))) (values ok output)))) diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index b4d5af3d7..9473ad862 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -14,9 +14,9 @@ (defvar *ecl-sources* (loop for *default-pathname-defaults* in - '(#p"@true_srcdir@/" #p"../../" #p"../../src/") - when (probe-file "configure.ac") - return *default-pathname-defaults*)) + '(#p"@true_srcdir@/" #p"../../" #p"../../src/") + when (probe-file "configure.ac") + return *default-pathname-defaults*)) (defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*)) @@ -25,20 +25,20 @@ (defvar *cache* (merge-pathnames "./cache/" *here*)) (defvar *test-image* (or (ext:getenv "TEST_IMAGE") - #+windows - (namestring (truename #+windows "sys:ecl.exe")) - #-windows - "@prefix@/bin/ecl")) + #+windows + (namestring (truename #+windows "sys:ecl.exe")) + #-windows + "@prefix@/bin/ecl")) (defvar *test-image-args* (cond ((search "ecl" *test-image*) - '("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))" - ;#+windows "-eval" #+windows "(require :cmp)" - )) - ((search "sbcl" *test-image*) - '("--no-userinit" "--no-sysinit")) - (t - '()))) + '("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))" + ;#+windows "-eval" #+windows "(require :cmp)" + )) + ((search "sbcl" *test-image*) + '("--no-userinit" "--no-sysinit")) + (t + '()))) #+ecl (ext:setenv "ECLDIR" (namestring (truename "SYS:"))) @@ -77,24 +77,24 @@ (defvar *fricas-tarball* "fricas.tar.gz") (defvar *wild-inferiors* (make-pathname :name :wild - :type :wild - :version :wild - :directory '(:relative :wild-inferiors))) + :type :wild + :version :wild + :directory '(:relative :wild-inferiors))) (defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data")) (defun lisp-system-directory () (loop with root = (si::get-library-pathname) - with lib-name = (format nil "../lib/ecl-~A/" (lisp-implementation-version)) - for base in (list root (merge-pathnames lib-name root)) - when (or (probe-file (merge-pathnames "./BUILD-STAMP" base)) - (probe-file (merge-pathnames "./LGPL" base))) - do (return base))) + with lib-name = (format nil "../lib/ecl-~A/" (lisp-implementation-version)) + for base in (list root (merge-pathnames lib-name root)) + when (or (probe-file (merge-pathnames "./BUILD-STAMP" base)) + (probe-file (merge-pathnames "./LGPL" base))) + do (return base))) (setf (logical-pathname-translations "SYS") (list (list #p"sys:**;*.*" - (merge-pathnames "**/*.*" - (lisp-system-directory))))) + (merge-pathnames "**/*.*" + (lisp-system-directory))))) (require :cmp) (require :ecl-curl) @@ -109,8 +109,8 @@ (require :asdf) (ensure-directories-exist *cache*) (setf (symbol-value (read-from-string "asdf::*user-cache*")) - (list *cache* :implementation))) - + (list *cache* :implementation))) + (defun delete-everything (path) ;; Recursively run through children @@ -142,16 +142,16 @@ (defun download-quicklisp-install () (safe-download "http://beta.quicklisp.org/quicklisp.lisp" - *quicklisp-install-file*)) + *quicklisp-install-file*)) (defun download-and-setup-quicklisp () (when (probe-file *quicklisp-sandbox*) (delete-everything *quicklisp-sandbox*)) (handler-case (progn - (load (download-quicklisp-install)) - (let ((function (read-from-string "quicklisp-quickstart:install"))) - (eval (list function :path *quicklisp-sandbox*)))) + (load (download-quicklisp-install)) + (let ((function (read-from-string "quicklisp-quickstart:install"))) + (eval (list function :path *quicklisp-sandbox*)))) (error (c) (format t "~&;;;~%;;; Unable to setup quicklisp. Aborting.~%;;;") (delete-everything *quicklisp-sandbox*)))) @@ -180,22 +180,22 @@ (format t "~&;;;~%;;; Extracting ~a~%;;;" filename) (if (string-equal (pathname-type filename) "gz") (let ((temp-filename (ext:mkstemp "fooXXXXXXX"))) - (unwind-protect - (progn - (deflate:gunzip filename temp-filename) - (extract-tarball temp-filename)) - (delete-file temp-filename))) + (unwind-protect + (progn + (deflate:gunzip filename temp-filename) + (extract-tarball temp-filename)) + (delete-file temp-filename))) (ql-minitar:unpack-tarball filename))) (defun extract-distribution (filename url) (let ((distribution (loop for base in (list *cache* - *here* - *test-sources*) - for file = (merge-pathnames filename base) - when (probe-file file) - do (return file) - finally (let ((tmp (merge-pathnames filename *cache*))) - (return (safe-download url tmp)))))) + *here* + *test-sources*) + for file = (merge-pathnames filename base) + when (probe-file file) + do (return file) + finally (let ((tmp (merge-pathnames filename *cache*))) + (return (safe-download url tmp)))))) (extract-tarball distribution))) (defun ensure-regressions () @@ -222,7 +222,7 @@ (defun cleanup-directory (path) (loop for i in (directory (merge-pathnames *wild-inferiors* - path)) + path)) when (member (pathname-type i) *cleanup-extensions* :test #'string-equal) do (delete-file i))) @@ -231,7 +231,7 @@ ;;; (defun run-ansi-tests (&optional (output (merge-pathnames "ansi.log" - *output-directory*))) + *output-directory*))) (ensure-ansi-tests) ;; Cleanup stray files (cleanup-directory *ansi-tests-sandbox*) @@ -239,31 +239,31 @@ ;; Run with given image (ensure-directories-exist output) (let* ((input (merge-pathnames "doit.lsp" *ansi-tests-sandbox*)) - (tmp (merge-pathnames "ecl-tmp-doit.lsp" *ansi-tests-sandbox*))) + (tmp (merge-pathnames "ecl-tmp-doit.lsp" *ansi-tests-sandbox*))) (with-open-file (s tmp :direction :output - :if-exists :supersede - :if-does-not-exist :create) + :if-exists :supersede + :if-does-not-exist :create) (format s "(require :cmp) #+ecl(setf c::*suppress-compiler-messages* '(or c::compiler-note c::style-warning)) (pprint (ext:getcwd)) (load ~S) #+ecl(quit)" - (namestring input))) + (namestring input))) (unwind-protect - (progn - (ext:chdir *ansi-tests-sandbox*) - (ext:run-program *test-image* - *test-image-args* - :input tmp - :output output - :error :output - :wait t)) + (progn + (ext:chdir *ansi-tests-sandbox*) + (ext:run-program *test-image* + *test-image-args* + :input tmp + :output output + :error :output + :wait t)) (when (probe-file tmp) - (ignore-errors (delete-file tmp))) + (ignore-errors (delete-file tmp))) (ext:chdir *here*)))) (defun run-regressions-tests (&optional (output (merge-pathnames "regressions.log" - *output-directory*))) + *output-directory*))) (ensure-regressions) ;; Cleanup stray files (cleanup-directory *regressions-sandbox*) @@ -271,47 +271,47 @@ (ensure-directories-exist output) (unwind-protect (progn - (ext:chdir *regressions-sandbox*) - (ext:run-program *test-image* - *test-image-args* - :input (merge-pathnames "doit.lsp" *regressions-sandbox*) - :output output - :error :output)) + (ext:chdir *regressions-sandbox*) + (ext:run-program *test-image* + *test-image-args* + :input (merge-pathnames "doit.lsp" *regressions-sandbox*) + :output output + :error :output)) (ext:chdir *here*))) (defun run-mop-tests (&optional (output (merge-pathnames "mop-features.log" - *output-directory*))) + *output-directory*))) (ensure-mop-tests) ;; Cleanup stray files (cleanup-directory *mop-tests-sandbox*) ;; Create the script we are going to run (let ((mop-script (merge-pathnames "./run-mop-tests.lisp" *mop-tests-sandbox*))) (with-open-file (s mop-script :direction :output - :if-exists :supersede - :if-does-not-exist :create) + :if-exists :supersede + :if-does-not-exist :create) (pprint '(progn - (require :asdf) - (load "lw-compat-package") - (load "lw-compat") - (load "mop-features-packages.lisp") - (load "mop-feature-tests.lisp") - (handler-case - (progn - (funcall (read-from-string "mop-feature-tests::run-feature-tests")) - (format t "~%~%~%MOP-FEATURE-TESTS: OK")) - (error (error) - (format t "~%~%~%MOP-FEATURE-TESTS: Failed")))) - s)) + (require :asdf) + (load "lw-compat-package") + (load "lw-compat") + (load "mop-features-packages.lisp") + (load "mop-feature-tests.lisp") + (handler-case + (progn + (funcall (read-from-string "mop-feature-tests::run-feature-tests")) + (format t "~%~%~%MOP-FEATURE-TESTS: OK")) + (error (error) + (format t "~%~%~%MOP-FEATURE-TESTS: Failed")))) + s)) ;; Run with given image (ensure-directories-exist output) (unwind-protect - (progn - (ext:chdir *mop-tests-sandbox*) - (ext:run-program *test-image* - *test-image-args* - :input mop-script - :output output - :error :output)) + (progn + (ext:chdir *mop-tests-sandbox*) + (ext:run-program *test-image* + *test-image-args* + :input mop-script + :output output + :error :output)) (ext:chdir *here*)))) @@ -380,38 +380,38 @@ ") (defun run-quicklisp-tests (&optional (output (merge-pathnames "quicklisp.log" - *output-directory*))) + *output-directory*))) (mapcar #'delete-everything (directory (merge-pathnames "*/" *cache*))) (let ((quicklisp-logs (merge-pathnames "quicklisp.logs/" *output-directory*))) (labels ((build-or-test-job (name suffix template) - (let* ((name (string-downcase name)) - (log-name (concatenate 'string name suffix)) - (build-log (ensure-directories-exist - (merge-pathnames log-name quicklisp-logs)))) - (multiple-value-bind (stream status process) - (ext:run-program *test-image* - *test-image-args* - :input :stream - :output build-log - :error :output - :wait nil) - (unwind-protect - (progn - (format stream template - (namestring *cache*) - (namestring *quicklisp-setup-file*) - name) - (format t template - (namestring *cache*) - (namestring *quicklisp-setup-file*) - name) - (force-output stream)) - (close stream) - (ext:external-process-wait process t) - )))) - (build-job (name) - (build-or-test-job name "-build.log" +quicklisp-build-template+)) - (test-job (name) - (build-or-test-job name "-test.log" +quicklisp-test-template+))) + (let* ((name (string-downcase name)) + (log-name (concatenate 'string name suffix)) + (build-log (ensure-directories-exist + (merge-pathnames log-name quicklisp-logs)))) + (multiple-value-bind (stream status process) + (ext:run-program *test-image* + *test-image-args* + :input :stream + :output build-log + :error :output + :wait nil) + (unwind-protect + (progn + (format stream template + (namestring *cache*) + (namestring *quicklisp-setup-file*) + name) + (format t template + (namestring *cache*) + (namestring *quicklisp-setup-file*) + name) + (force-output stream)) + (close stream) + (ext:external-process-wait process t) + )))) + (build-job (name) + (build-or-test-job name "-build.log" +quicklisp-build-template+)) + (test-job (name) + (build-or-test-job name "-test.log" +quicklisp-test-template+))) (mapc #'build-job *quicklisp-library-list*) (mapc #'test-job *quicklisp-library-list*)))) diff --git a/src/util/cut.c b/src/util/cut.c index 64def9a4a..c5d723d0c 100755 --- a/src/util/cut.c +++ b/src/util/cut.c @@ -18,13 +18,13 @@ sed_emulator(int narg, char **patterns) for (i = 0; i < narg; i+=2) { char *b3, *b4; while ((b3 = strstr(b1, patterns[i]))) { - if (strcmp(patterns[i+1], "/DELETE/") == 0) - goto GO_ON; - b3[0] = 0; - strcpy(b2, b1); - strcat(b2, patterns[i+1]); - strcat(b2, b3 + lengths[i]); - b4 = b2; b2 = b1; b1 = b4; + if (strcmp(patterns[i+1], "/DELETE/") == 0) + goto GO_ON; + b3[0] = 0; + strcpy(b2, b1); + strcat(b2, patterns[i+1]); + strcat(b2, b3 + lengths[i]); + b4 = b2; b2 = b1; b1 = b4; } } puts(b1); @@ -45,7 +45,7 @@ main(int narg, char **argv) { char *new = strdup(argv[i]); for (j = 0; new[j]; j++) { if (new[j] == '\\') { - new[j] = '/'; + new[j] = '/'; } } argv[i] = new; @@ -61,7 +61,7 @@ main(int narg, char **argv) { if (narg == 0) { /* This is used to remove part of config.h */ if (strstr(buffer, "-CUT-")) { - exit(0); + exit(0); } } puts(buffer); diff --git a/src/util/defsys.lsp b/src/util/defsys.lsp index 8af0df557..c1251f5fe 100644 --- a/src/util/defsys.lsp +++ b/src/util/defsys.lsp @@ -3,12 +3,12 @@ ;;; (c) Copyright G. Attardi, 1990. All rights reserved. ;;; ********************************************************************** -(defparameter *util-directory* "") +(defparameter *util-directory* "") (sbt:defsystem util :modules - '((system t t ()) ; a system building tool + '((system t t ()) ; a system building tool ) :directory *util-directory* diff --git a/src/util/gen-code.lisp b/src/util/gen-code.lisp index 790f00713..c2072a067 100644 --- a/src/util/gen-code.lisp +++ b/src/util/gen-code.lisp @@ -4,37 +4,37 @@ (defun process-file (filename) (let* ((filename (merge-pathnames filename)) - (name (pathname-name filename)) - (input (make-pathname :name (concatenate 'string "bak-" name) - :type (pathname-type filename) - :directory (pathname-directory filename))) - (output filename)) + (name (pathname-name filename)) + (input (make-pathname :name (concatenate 'string "bak-" name) + :type (pathname-type filename) + :directory (pathname-directory filename))) + (output filename)) (cond ((not (probe-file filename)) - (error "Unable to find ~a" filename)) - ((probe-file input) - (error "Backup already exists" input)) - (t - (format t "~%;;; Renaming ~a -> ~a" filename input) - (rename-file filename input))) + (error "Unable to find ~a" filename)) + ((probe-file input) + (error "Backup already exists" input)) + (t + (format t "~%;;; Renaming ~a -> ~a" filename input) + (rename-file filename input))) (with-open-file (in input :direction :input) (with-open-file (out output :direction :output :if-exists :supersede) - (format t "~%;;; Transforming ~a -> ~a" input output) - (loop with skip = nil - for l = (read-line in nil nil nil) - while l - do (cond (skip - (when (search "END-GENERATED" l) - (write-line l out) - (setf skip nil))) - (t - (write-line l out) - (let ((ndx (search "BEGIN-GENERATED" l))) - (when ndx - (let* ((*standard-output* out) - (form-text (subseq l (+ ndx 15))) - (form (read-from-string form-text))) - (eval form) - (setf skip t))))))))) + (format t "~%;;; Transforming ~a -> ~a" input output) + (loop with skip = nil + for l = (read-line in nil nil nil) + while l + do (cond (skip + (when (search "END-GENERATED" l) + (write-line l out) + (setf skip nil))) + (t + (write-line l out) + (let ((ndx (search "BEGIN-GENERATED" l))) + (when ndx + (let* ((*standard-output* out) + (form-text (subseq l (+ ndx 15))) + (form (read-from-string form-text))) + (eval form) + (setf skip t))))))))) (format t "~%;;; Deleting the file ~a" input) (delete-file input))) @@ -52,19 +52,19 @@ (:unsafe (format t "~%~acl_object _ecl_c~ar(cl_object x)~%{" prefix string) (loop for what in (reverse list) - for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR") - do (format t "~% if (Null(x)) return x;~% x = ~A(x);" op)) + for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR") + do (format t "~% if (Null(x)) return x;~% x = ~A(x);" op)) (format t "~% return x;~%}~%")) (:safe (format t "~%cl_object ecl_c~ar(cl_object x)~%{" string) (loop for what in (reverse list) - for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR") - do (format t "~% if (ecl_unlikely(!ECL_LISTP(x))) FEwrong_type_nth_arg(@[car], 1, x, @[list]);") - do (format t "~% if (Null(x)) return x;~% x = ~A(x);" op)) + for op = (if (eq what 'a) "ECL_CONS_CAR" "ECL_CONS_CDR") + do (format t "~% if (ecl_unlikely(!ECL_LISTP(x))) FEwrong_type_nth_arg(@[car], 1, x, @[list]);") + do (format t "~% if (Null(x)) return x;~% x = ~A(x);" op)) (format t "~% return x;~%}~%")) (:common-lisp (format t "~%cl_object cl_c~ar(cl_object x)~%{~% return1(ecl_c~ar(x));~%}~%" - string string)) + string string)) (:declare-unsafe (format t "~%extern ECL_API cl_object _ecl_c~ar(cl_object);" string)) (:declare-safe @@ -80,39 +80,39 @@ (defun gen-cons-h () (format t "~%#if ECL_CAN_INLINE") (loop for depth from 1 below 5 - do (write-rec depth nil :inline)) + do (write-rec depth nil :inline)) (format t "~%#else") (loop for depth from 1 below 5 - do (write-rec depth nil :declare-unsafe)) + do (write-rec depth nil :declare-unsafe)) (format t "~%#endif /* !ECL_CAN_INLINE */~%") (loop for depth from 1 below 5 - do (write-rec depth nil :declare-safe)) + do (write-rec depth nil :declare-safe)) (terpri) (gen-cons-legacy-h) (loop for depth from 1 below 5 - do (write-rec depth nil :declare-common-lisp)) + do (write-rec depth nil :declare-common-lisp)) (terpri)) (defun gen-cons-d () (format t "~%#if !ECL_CAN_INLINE") (loop for depth from 1 below 5 - do (write-rec depth nil :unsafe)) + do (write-rec depth nil :unsafe)) (format t "~%#endif /* !ECL_CAN_INLINE */~%") (loop for depth from 1 below 5 - do (write-rec depth nil :safe)) + do (write-rec depth nil :safe)) (terpri) (loop for depth from 1 below 5 - do (write-rec depth nil :common-lisp)) + do (write-rec depth nil :common-lisp)) (terpri)) (defun gen-cons-legacy-h () (loop for depth from 1 below 5 - do (write-rec depth nil :unsafe-macro)) + do (write-rec depth nil :unsafe-macro)) (terpri)) (defun gen-cons-sysfun () (loop for depth from 1 below 5 - do (write-rec depth nil :common-lisp-inline)) + do (write-rec depth nil :common-lisp-inline)) (terpri)) (process-file "src/c/cons.d") diff --git a/src/util/system.lsp b/src/util/system.lsp index 0b991f99e..8542edf29 100644 --- a/src/util/system.lsp +++ b/src/util/system.lsp @@ -35,27 +35,27 @@ (defpackage "SBT" (:use "CL") (:export defsystem - build-system - compile-system - load-system - build-ecl)) + build-system + compile-system + load-system + build-ecl)) (in-package "SBT") (defmacro defsystem (name &key modules - (source-directory '("./")) - (source-extension "lsp") - (fasl-directory "./") - (fasl-extension "o") - (library-directory "./")) - `(defparameter ,name ; rather then defvar + (source-directory '("./")) + (source-extension "lsp") + (fasl-directory "./") + (fasl-extension "o") + (library-directory "./")) + `(defparameter ,name ; rather then defvar (make-system :NAME ',name - :MODULES ,modules - :SOURCE-DIRECTORY ,(if (consp source-directory) source-directory (list 'quote (list source-directory))) - :SOURCE-EXTENSION ,source-extension - :FASL-DIRECTORY ,fasl-directory - :FASL-EXTENSION ,fasl-extension - :LIBRARY-DIRECTORY ,library-directory))) + :MODULES ,modules + :SOURCE-DIRECTORY ,(if (consp source-directory) source-directory (list 'quote (list source-directory))) + :SOURCE-EXTENSION ,source-extension + :FASL-DIRECTORY ,fasl-directory + :FASL-EXTENSION ,fasl-extension + :LIBRARY-DIRECTORY ,library-directory))) ;;; ---------------------------------------------------------------------- @@ -70,23 +70,23 @@ (defun make-source-pathname (name system) (let ((name (string-downcase name)) - (extension (system-source-extension system))) + (extension (system-source-extension system))) (dolist (i (system-source-directory system)) (let ((pathname (make-pathname :name name :type extension - :defaults i))) - (let ((ok (probe-file pathname))) - (when ok (return-from make-source-pathname ok))))) + :defaults i))) + (let ((ok (probe-file pathname))) + (when ok (return-from make-source-pathname ok))))) (error "sbt::make-source-pathname: source file not found"))) (defun make-binary-pathname (name system) (make-pathname :name (string-downcase name) - :type (system-fasl-extension system) - :defaults (system-fasl-directory system))) + :type (system-fasl-extension system) + :defaults (system-fasl-directory system))) (defun make-library-pathname (system target) (let* ((name (string-downcase (system-name system))) - (directory (system-library-directory system)) - (output-name (merge-pathnames name directory))) + (directory (system-library-directory system)) + (output-name (merge-pathnames name directory))) (compile-file-pathname output-name :type target))) ;;; ---------------------------------------------------------------------- @@ -94,12 +94,12 @@ ;;; (defstruct (module (:TYPE vector) :NAMED - (:CONSTRUCTOR make-module (name)) + (:CONSTRUCTOR make-module (name)) ; (:PRINT-FUNCTION ; (lambda (m s d) ; (declare (ignore d)) ; (format s "#" (module-name m)))) - ) + ) name load-env comp-env @@ -143,8 +143,8 @@ (unless (dolist (trans transforms) (when (eq (second trans) module) (case (first trans) - (:COMPILE (return nil)) - (:LOAD (return trans))))) + (:COMPILE (return nil)) + (:LOAD (return trans))))) (dolist (l (module-load-env module)) (make-load-transformation l transforms)) (push `(:LOAD ,module) (cdr transforms)))) @@ -172,58 +172,58 @@ (apply #'compiler::compile-file a)) (defun operate-on-system (system mode &optional arg print-only - &aux (si::*init-function-prefix* - (string-upcase (system-name system)))) + &aux (si::*init-function-prefix* + (string-upcase (system-name system)))) (let (transformations) (flet ((load-module (m s) (let ((name (module-name m))) - #-dlopen - (if print-only - (format t "~&Loading source of ~A..." name) - (load (make-source-pathname name s))) - #+dlopen + #-dlopen + (if print-only + (format t "~&Loading source of ~A..." name) + (load (make-source-pathname name s))) + #+dlopen (if (or (eq mode :source) - (dolist (trans transformations) - (and (eq (first trans) :compile) - (eq (second trans) m) - ; Is this ok? - (return nil)))) + (dolist (trans transformations) + (and (eq (first trans) :compile) + (eq (second trans) m) + ; Is this ok? + (return nil)))) (if print-only - (format t "~&Loading source of ~A..." name) - (load (make-source-pathname name s))) + (format t "~&Loading source of ~A..." name) + (load (make-source-pathname name s))) (if print-only - (format t "~&Loading binary of ~A..." name) - (load (make-binary-pathname name s)))))) + (format t "~&Loading binary of ~A..." name) + (load (make-binary-pathname name s)))))) (compile-module (m s) (format t "~&Compiling ~A..." (module-name m)) (unless print-only - (let ((name (module-name m))) + (let ((name (module-name m))) (sbt-compile-file (make-source-pathname name s) - :OUTPUT-FILE (make-binary-pathname name s))))) + :OUTPUT-FILE (make-binary-pathname name s))))) - (true (&rest ignore) (declare (ignore ignore)) 't)) + (true (&rest ignore) (declare (ignore ignore)) 't)) (setq transformations (ecase mode - ((:STATIC-LIBRARY :LIBRARY :SHARED-LIBRARY :FASL) - (let* ((transforms (make-transformations system - #'true - #'make-load-transformation)) - (objects (mapcar #'(lambda (x) (make-binary-pathname (module-name (cadr x)) system)) - (remove-if-not #'(lambda (x) (eq (car x) :LOAD)) - transforms))) - (library (make-library-pathname system mode))) - (operate-on-system system :COMPILE) - (c::builder mode library :lisp-files objects)) - nil) + ((:STATIC-LIBRARY :LIBRARY :SHARED-LIBRARY :FASL) + (let* ((transforms (make-transformations system + #'true + #'make-load-transformation)) + (objects (mapcar #'(lambda (x) (make-binary-pathname (module-name (cadr x)) system)) + (remove-if-not #'(lambda (x) (eq (car x) :LOAD)) + transforms))) + (library (make-library-pathname system mode))) + (operate-on-system system :COMPILE) + (c::builder mode library :lisp-files objects)) + nil) (:COMPILE (make-transformations system #'compile-filter #'make-compile-transformation)) (:RECOMPILE (make-transformations system - #'true + #'true #'make-compile-transformation)) (:QUERY-COMPILE (make-transformations system @@ -240,28 +240,28 @@ #'make-compile-transformation)) ((:LOAD :SOURCE) (make-transformations system - #'true + #'true #'make-load-transformation)) (:QUERY-LOAD (make-transformations system #'(lambda (s m transforms) - (declare (ignore s transforms)) + (declare (ignore s transforms)) (y-or-n-p "Load ~A?" (module-name m))) #'make-load-without-dependencies-transformation)))) (dolist (transform transformations) - (ecase (first transform) - (:COMPILE (compile-module (second transform) system)) - (:LOAD (load-module (second transform) system))))))) + (ecase (first transform) + (:COMPILE (compile-module (second transform) system)) + (:LOAD (load-module (second transform) system))))))) (defun compile-system (system &optional m) (cond ((null m) (operate-on-system system :COMPILE)) - ((eq m 't) (operate-on-system system :RECOMPILE)) - ((eq m :PRINT) (operate-on-system system :COMPILE () t)) - ((eq m :QUERY) (operate-on-system system :QUERY-COMPILE)) - ((symbolp m) (operate-on-system system :COMPILE-FROM (list m))) - ((listp m) (operate-on-system system :COMPILE-FROM m)))) + ((eq m 't) (operate-on-system system :RECOMPILE)) + ((eq m :PRINT) (operate-on-system system :COMPILE () t)) + ((eq m :QUERY) (operate-on-system system :QUERY-COMPILE)) + ((symbolp m) (operate-on-system system :COMPILE-FROM (list m))) + ((listp m) (operate-on-system system :COMPILE-FROM m)))) (defun load-system (system &optional mode) (case mode @@ -275,15 +275,15 @@ (defmacro build-system (system &optional op mode) (case op - (:LOAD - `(load-system ,system ,(case mode - (:QUERY :QUERY-LOAD) - (:SOURCE :SOURCE)))) - (:COMPILE - `(compile-system ,system ,(case mode - (:QUERY :QUERY-COMPILE) - (:FORCE :RECOMPILE)))) - (:PRINT - `(compile-system ,system :PRINT)) - (otherwise - `(load-system ,system)))) + (:LOAD + `(load-system ,system ,(case mode + (:QUERY :QUERY-LOAD) + (:SOURCE :SOURCE)))) + (:COMPILE + `(compile-system ,system ,(case mode + (:QUERY :QUERY-COMPILE) + (:FORCE :RECOMPILE)))) + (:PRINT + `(compile-system ,system :PRINT)) + (otherwise + `(load-system ,system))))